diff --git a/configure b/configure
index 3cf52ca73..f06dc7453 100755
--- a/configure
+++ b/configure
@@ -7675,8 +7675,18 @@ if test "X$HAS_CFLAGS" = "X" ;then
CONF_OPT="$CONF_OPT \\\"CPPFLAGS=$CPPFLAGS\\\""
fi
-
-CONF_SUMMARY="(#:system ($SYST_LIBS) #:compiled ($COMP_LIBS) #:configure ($CONF_OPT))"
+# Build the CONF_SUMMARY variable
+confdirs="("
+confdirs="${confdirs} #:libdir \\\"$libdir\\\" #:datadir \\\"$datadir\\\""
+confdirs="${confdirs} #:docdir \\\"$docdir\\\" #:htmldir \\\"$htmldir\\\" #:pdfdir \\\"$pdfdir\\\""
+confdirs="${confdirs})"
+
+confsum="("
+confsum="${confsum} #:system ($SYST_LIBS) #:compiled ($COMP_LIBS) #:configure ($CONF_OPT)"
+confsum="${confsum} #:dirs ${confdirs}"
+confsum="${confsum})"
+
+CONF_SUMMARY="${confsum}"
# Determine the STRIP command to use
if test "X$STRIP" = "X" ;then
diff --git a/configure.ac b/configure.ac
index 88ba7924a..3e8eab70b 100644
--- a/configure.ac
+++ b/configure.ac
@@ -578,8 +578,18 @@ if test "X$HAS_CFLAGS" = "X" ;then
CONF_OPT="$CONF_OPT \\\"CPPFLAGS=$CPPFLAGS\\\""
fi
-
-CONF_SUMMARY="(#:system ($SYST_LIBS) #:compiled ($COMP_LIBS) #:configure ($CONF_OPT))"
+# Build the CONF_SUMMARY variable
+confdirs="("
+confdirs="${confdirs} #:libdir \\\"$libdir\\\" #:datadir \\\"$datadir\\\""
+confdirs="${confdirs} #:docdir \\\"$docdir\\\" #:htmldir \\\"$htmldir\\\" #:pdfdir \\\"$pdfdir\\\""
+confdirs="${confdirs})"
+
+confsum="("
+confsum="${confsum} #:system ($SYST_LIBS) #:compiled ($COMP_LIBS) #:configure ($CONF_OPT)"
+confsum="${confsum} #:dirs ${confdirs}"
+confsum="${confsum})"
+
+CONF_SUMMARY="${confsum}"
# Determine the STRIP command to use
if test "X$STRIP" = "X" ;then
diff --git a/doc/HTML/pp.html b/doc/HTML/pp.html
index 762aa5491..b77b0ead6 100644
--- a/doc/HTML/pp.html
+++ b/doc/HTML/pp.html
@@ -677,7 +677,11 @@
.tocify-focus > a {
color: #7a2518;
-}
+ }
+
+ /* Customize default CSS */
+.sidebarblock { margin-top: -1em; }
+
-
-
-
-
-
-
+
-
-
STklos syntax
+
@@ -1863,15 +1809,16 @@
2.4. Conditionals
returned. Otherwise,
when
returns
void .
-
-
STklos syntax
+
@@ -1898,16 +1845,17 @@
2.5. Binding Constructs
STklos also provides a fluid-let
form which is described below.
-
-
R5 RS syntax
+
@@ -1970,15 +1918,16 @@
2.5. Binding Constructs
-
-
R5 RS syntax
+
@@ -2009,15 +1958,16 @@
2.5. Binding Constructs
-
-
R5 RS syntax
+
@@ -2049,15 +1999,16 @@
2.5. Binding Constructs
-
-
R7 RS syntax
+
@@ -2092,15 +2043,16 @@
2.5. Binding Constructs
-
-
R7 RS syntax
+
@@ -2132,15 +2084,16 @@
2.5. Binding Constructs
-
-
R7 RS syntax
+
@@ -2163,15 +2116,16 @@
2.5. Binding Constructs
-
-
R7 RS procedure
+
@@ -2197,15 +2151,16 @@
2.5. Binding Constructs
-
-
STklos syntax
+
@@ -2253,15 +2208,16 @@
2.5. Binding Constructs
2.6. Sequencing
-
-
R5 RS syntax
+
@@ -2283,17 +2239,18 @@
2.6. Sequencing
-
-
STklos syntax
+
@@ -2335,15 +2292,16 @@
2.6. Sequencing
2.7. Iterations
-
-
R5 RS syntax
+
@@ -2404,16 +2362,17 @@
2.7. Iterations
-
-
STklos syntax
+
@@ -2435,15 +2394,16 @@
2.7. Iterations
-
-
STklos syntax
+
@@ -2464,15 +2424,16 @@
2.7. Iterations
-
-
STklos syntax
+
@@ -2481,15 +2442,16 @@
2.7. Iterations
value. The value returned by this form is
void .
-
-
STklos syntax
+
@@ -2506,15 +2468,16 @@
2.8. Delayed Evaluation
-
-
R5 RS syntax
+
@@ -2531,17 +2494,18 @@
2.8. Delayed Evaluation
description of
delay
.
-
-
R7 RS syntax
+
@@ -2558,15 +2522,16 @@
2.8. Delayed Evaluation
The special form delay-force
appears with name lazy
in SRFI-45 (Primitives for Expressing Iterative Lazy Algorithms ).
-
-
R5 RS procedure
+
@@ -2629,15 +2594,16 @@
2.8. Delayed Evaluation
-
-
R7 RS procedure
+
@@ -2645,17 +2611,18 @@
2.8. Delayed Evaluation
Returns #t
if obj
is a promise, otherwise returns #f
.
-
-
R7 RS procedure
+
@@ -2679,16 +2646,17 @@
2.9. Quasiquotation
+
-
-
R5 RS syntax
+
@@ -2782,16 +2750,17 @@
2.10. Macros
and R. Kent Dybvig.
-
-
STklos syntax
+
@@ -2823,15 +2792,16 @@
2.10. Macros
-
-
R5 RS syntax
+
@@ -2865,15 +2835,16 @@
2.10. Macros
-
-
R5 RS syntax
+
@@ -2914,15 +2885,16 @@
2.10. Macros
-
-
R5 RS syntax
+
@@ -2977,15 +2949,16 @@
2.10. Macros
-
-
R5 RS syntax
+
@@ -3037,17 +3010,18 @@
2.10. Macros
-
-
STklos procedure
+
@@ -3119,15 +3093,16 @@
3. Program structure
3.1. Modules
-
-
STklos syntax
+
@@ -3189,16 +3164,17 @@
3.1. Modules
-
-
STklos procedure
+
@@ -3209,15 +3185,16 @@
3.1. Modules
provided, otherwise
find-module
returns
default
.
-
-
STklos procedure
+
@@ -3232,15 +3209,16 @@
3.1. Modules
-
-
STklos procedure
+
@@ -3259,15 +3237,16 @@
3.1. Modules
-
-
STklos procedure
+
@@ -3283,15 +3262,16 @@
3.1. Modules
-
-
STklos syntax
+
@@ -3322,16 +3302,17 @@
3.1. Modules
-
-
STklos procedure
+
@@ -3341,16 +3322,17 @@
3.1. Modules
returns
default
.
Module
can be an object module or a module name.
-
-
STklos procedure
+
@@ -3364,16 +3346,17 @@
3.1. Modules
and in the STklos module if module is not a R
7 RS library.
-
-
STklos procedure
+
@@ -3382,15 +3365,16 @@
3.1. Modules
omitted it defaults to the current module.
-
-
STklos procedure
+
@@ -3399,15 +3383,16 @@
3.1. Modules
can be an object module or a module name.
-
-
STklos procedure
+
@@ -3417,15 +3402,16 @@
3.1. Modules
is not a R
7 RS library.
-
-
STklos syntax
+
@@ -3475,15 +3461,16 @@
3.1. Modules
-
-
STklos syntax
+
@@ -3636,15 +3623,16 @@
3.1. Modules
suffixes applies to find those files).
-
-
STklos procedure
+
@@ -3653,15 +3641,16 @@
3.1. Modules
it depends on).
-
-
STklos procedure
+
@@ -3679,15 +3668,16 @@
3.1. Modules
-
-
STklos procedure
+
@@ -3696,15 +3686,16 @@
3.1. Modules
to define new symbols in it or change the value of already defined ones.
-
-
STklos procedure
+
@@ -3721,16 +3712,17 @@
3.1. Modules
-
-
STklos syntax
+
@@ -3757,15 +3749,16 @@
3.1. Modules
-
-
STklos procedure
+
@@ -3774,15 +3767,16 @@
3.1. Modules
module-list
to obtain a list of modules without libraries.
-
-
STklos procedure
+
@@ -3808,15 +3802,16 @@
3.2. Libraries
+
-
-
R7 RS syntax
+
@@ -3871,15 +3866,16 @@
3.2. Libraries
-
-
STklos procedure
+
@@ -3900,15 +3896,16 @@
3.2. Libraries
-
-
STklos procedure
+
@@ -3933,15 +3930,16 @@
3.2. Libraries
-
-
STklos procedure
+
@@ -3954,17 +3952,18 @@
3.2. Libraries
3.3. Variables and Constants
-
-
R5 RS syntax
+
@@ -4007,17 +4006,18 @@
3.3. Variables and Constants
-
-
STklos procedure
+
@@ -4035,16 +4035,17 @@
3.3. Variables and Constants
-
-
STklos procedure
+
@@ -4062,16 +4063,17 @@
3.3. Variables and Constants
-
-
STklos procedure
+
@@ -4110,15 +4112,16 @@
4.1. Equivalence predicates
Eqv?
is slightly less discriminating than
eq?
.
-
-
R5 RS procedure
+
@@ -4243,15 +4246,16 @@
4.1. Equivalence predicates
See R5 RS for more details on eqv?
.
-
-
R5 RS procedure
+
@@ -4307,15 +4311,16 @@
4.1. Equivalence predicates
-
-
R5 RS procedure
+
@@ -4367,23 +4372,24 @@
4.2. Numbers
infinity),
+nan.0
(not a number), and
-nan.0
(not a number).
-
-
R5 RS procedure
+
@@ -4423,17 +4429,18 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -4443,17 +4450,18 @@
4.2. Numbers
is true.
-
-
R7 RS procedure
+
@@ -4462,15 +4470,16 @@
4.2. Numbers
and
inexact→exact
procedure respectively
-
-
R7 RS procedure
+
@@ -4485,15 +4494,16 @@
4.2. Numbers
-
-
STklos procedure
+
@@ -4509,23 +4519,24 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -4553,7 +4564,8 @@
4.2. Numbers
-
+
+
@@ -4561,19 +4573,19 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -4590,15 +4602,16 @@
4.2. Numbers
-
-
R7 RS procedure
+
@@ -4617,16 +4630,17 @@
4.2. Numbers
-
-
STklos procedure
+
@@ -4643,15 +4657,16 @@
4.2. Numbers
This function is defined in SRFI-208 .
-
-
STklos procedure
+
@@ -4659,15 +4674,16 @@
4.2. Numbers
returns #t
if the sign bit of nan
is set and #f
otherwise.
-
-
STklos procedure
+
@@ -4675,15 +4691,16 @@
4.2. Numbers
returns #t
if nan
is a quiet NaN.
-
-
STklos procedure
+
@@ -4691,15 +4708,16 @@
4.2. Numbers
returns the payload bits of nan
as a positive exact integer.
-
-
STklos procedure
+
@@ -4708,17 +4726,18 @@
4.2. Numbers
and payload; and
#f
otherwise.
-
-
R5 RS procedure
+
@@ -4754,25 +4773,26 @@
4.2. Numbers
-
-
R7 RS procedure
+
@@ -4799,17 +4819,18 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -4851,19 +4872,20 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -4887,15 +4909,16 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -4925,19 +4948,20 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -5001,17 +5025,18 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -5029,17 +5054,18 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -5058,21 +5084,22 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -5127,15 +5154,16 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -5159,7 +5187,8 @@
4.2. Numbers
-
+
+
@@ -5168,22 +5197,22 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -5211,25 +5240,26 @@
4.2. Numbers
argument.
-
-
STklos procedure
+
@@ -5279,17 +5309,18 @@
4.2. Numbers
-
-
STklos procedure
+
@@ -5298,15 +5329,16 @@
4.2. Numbers
from degrees into radians.
-
-
R5 RS procedure
+
@@ -5315,15 +5347,16 @@
4.2. Numbers
positive real part, or zero real part and non-negative imaginary part.
-
-
R7 RS procedure
+
@@ -5337,15 +5370,16 @@
4.2. Numbers
-
-
R7 RS procedure
+
@@ -5360,15 +5394,16 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -5388,25 +5423,26 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -5453,17 +5489,18 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -5476,16 +5513,17 @@
4.2. Numbers
the argument.
-
-
R5 RS procedure
+
@@ -5546,16 +5584,17 @@
4.2. Numbers
-
-
R5 RS procedure
+
@@ -5579,23 +5618,24 @@
4.2. Numbers
-
-
STklos procedure
+
@@ -5620,15 +5660,16 @@
4.2. Numbers
-
-
STklos procedure
+
@@ -5637,18 +5678,19 @@
4.2. Numbers
this procedure appear to be independent uniformly distributed over
the range [0, …,
n
[. The argument
n
must be a positive integer,
otherwise an error is signaled. This function is equivalent to the eponym
-function of
SRFI-27 (
Source of random bits ).
+function of SRFI-27 (see ,(link-srfi 27) definition for more details).
-
-
STklos procedure
+
@@ -5656,18 +5698,19 @@
4.2. Numbers
Return a real number r
such that 0 < r < 1
.
Subsequent results of this procedure appear to be independent uniformly
distributed. This function is equivalent to the eponym
-function of SRFI-27 (Source of random bits ).
+function of SRFI-27 (see ,(link-srfi 27) definition for more details).
-
-
STklos procedure
+
@@ -5695,15 +5738,16 @@
4.2. Numbers
-
-
STklos procedure
+
@@ -5748,19 +5792,20 @@
4.2. Numbers
-
-
STklos procedure
+
@@ -5770,15 +5815,16 @@
4.2. Numbers
the
encode-float
procedure.
-
-
STklos procedure
+
@@ -5815,15 +5861,16 @@
4.2.1. Fixnums
SRFI-143 (
Fixnums )
-
-
STklos procedure
+
@@ -5832,15 +5879,16 @@
4.2.1. Fixnums
#f
otherwise.
-
-
STklos procedure
+
@@ -5848,17 +5896,18 @@
4.2.1. Fixnums
Returns the number of bits used to represent a fixnum number.
-
-
STklos procedure
+
@@ -5867,15 +5916,16 @@
4.2.1. Fixnums
the fixnum range.
-
-
STklos procedure
+
@@ -5892,17 +5942,18 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -5924,16 +5975,17 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -5954,7 +6006,8 @@
4.2.1. Fixnums
-
+
+
@@ -5963,20 +6016,20 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -5988,17 +6041,18 @@
4.2.1. Fixnums
computes the absolute value of
fx
.
-
-
STklos procedure
+
@@ -6019,17 +6073,18 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6045,23 +6100,24 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6073,21 +6129,22 @@
4.2.1. Fixnums
fx=?
returns
#t
if the arguments are all equal.
-
-
STklos procedure
+
@@ -6106,19 +6163,20 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6136,15 +6194,16 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6160,15 +6219,16 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6187,15 +6247,16 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6212,15 +6273,16 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6236,15 +6298,16 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6261,15 +6324,16 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6287,15 +6351,16 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6310,15 +6375,16 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6334,15 +6400,16 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6357,15 +6424,16 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6380,15 +6448,16 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6403,15 +6472,16 @@
4.2.1. Fixnums
-
-
STklos procedure
+
@@ -6443,15 +6513,16 @@
4.3. Booleans
quoted in programs.
-
-
R5 RS procedure
+
@@ -6470,15 +6541,16 @@
4.3. Booleans
-
-
R5 RS procedure
+
@@ -6494,15 +6566,16 @@
4.3. Booleans
-
-
R5 RS procedure
+
@@ -6515,15 +6588,16 @@
4.4. Pairs and lists
-
-
R5 RS procedure
+
@@ -6531,15 +6605,16 @@
4.4. Pairs and lists
Pair?
returns #t
if obj
is a pair, and otherwise returns #f
.
-
-
R5 RS procedure
+
@@ -6558,15 +6633,16 @@
4.4. Pairs and lists
-
-
R5 RS procedure
+
@@ -6583,15 +6659,16 @@
4.4. Pairs and lists
-
-
R5 RS procedure
+
@@ -6607,15 +6684,16 @@
4.4. Pairs and lists
-
-
R5 RS procedure
+
@@ -6632,15 +6710,16 @@
4.4. Pairs and lists
-
-
R5 RS procedure
+
@@ -6649,7 +6728,8 @@
4.4. Pairs and lists
The value returned by
set-cdr!
is
void .
-
+
+
@@ -6678,17 +6758,17 @@
4.4. Pairs and lists
-
-
R5 RS procedure
+
@@ -6706,15 +6786,16 @@
4.4. Pairs and lists
There are twenty-eight of these procedures in all.
-
-
R5 RS procedure
+
@@ -6722,15 +6803,16 @@
4.4. Pairs and lists
Returns #t
if obj
is the empty list, otherwise returns #f
.
-
-
STklos procedure
+
@@ -6745,15 +6827,16 @@
4.4. Pairs and lists
-
-
R5 RS procedure
+
@@ -6772,16 +6855,17 @@
4.4. Pairs and lists
-
-
R7 RS procedure
+
@@ -6791,15 +6875,16 @@
4.4. Pairs and lists
Otherwise the initial contents of each element is unspecified.
-
-
R5 RS procedure
+
@@ -6813,15 +6898,16 @@
4.4. Pairs and lists
-
-
STklos procedure
+
@@ -6837,15 +6923,16 @@
4.4. Pairs and lists
-
-
R5 RS procedure
+
@@ -6860,15 +6947,16 @@
4.4. Pairs and lists
-
-
R5 RS procedure
+
@@ -6896,15 +6984,16 @@
4.4. Pairs and lists
-
-
STklos procedure
+
@@ -6928,15 +7017,16 @@
4.4. Pairs and lists
An error is signaled if one of the given lists is a constant list.
-
-
R5 RS procedure
+
@@ -6951,15 +7041,16 @@
4.4. Pairs and lists
-
-
STklos procedure
+
@@ -6976,15 +7067,16 @@
4.4. Pairs and lists
-
-
R5 RS procedure
+
@@ -7003,15 +7095,16 @@
4.4. Pairs and lists
-
-
STklos procedure
+
@@ -7025,15 +7118,16 @@
4.4. Pairs and lists
-
-
R5 RS procedure
+
@@ -7050,15 +7144,16 @@
4.4. Pairs and lists
-
-
R7 RS procedure
+
@@ -7075,20 +7170,21 @@
4.4. Pairs and lists
-
-
R5 RS / R7 RS procedure
+
@@ -7129,20 +7225,21 @@
4.4. Pairs and lists
-
-
R5 RS / R7 RS procedure
+
@@ -7198,15 +7295,16 @@
4.4. Pairs and lists
-
-
R7 RS procedure
+
@@ -7217,17 +7315,18 @@
4.4. Pairs and lists
the
car
and
cdr
of
obj
, respectively.
-
-
STklos procedure
+
@@ -7250,16 +7349,17 @@
4.4. Pairs and lists
An error is signaled if list
is a constant list.
-
-
STklos procedure
+
@@ -7277,17 +7377,18 @@
4.4. Pairs and lists
-
-
STklos procedure
+
@@ -7351,15 +7452,16 @@
4.5. Symbols
-
-
R5 RS procedure
+
@@ -7378,15 +7480,16 @@
4.5. Symbols
-
-
R5 RS procedure
+
@@ -7395,15 +7498,16 @@
4.5. Symbols
the sense of
string=?
.
-
-
R5 RS procedure
+
@@ -7427,15 +7531,16 @@
4.5. Symbols
-
-
R5 RS procedure
+
@@ -7472,15 +7577,16 @@
4.5. Symbols
-
-
STklos procedure
+
@@ -7500,16 +7606,17 @@
4.5. Symbols
-
-
STklos procedure
+
@@ -7707,15 +7814,16 @@
4.6. Characters
-
-
R5 RS procedure
+
@@ -7723,23 +7831,24 @@
4.6. Characters
Returns #t
if obj
is a character, otherwise returns #f
.
-
-
R5 RS procedure
+
@@ -7768,23 +7877,24 @@
4.6. Characters
-
-
R5 RS procedure
+
@@ -7794,23 +7904,24 @@
4.6. Characters
(char-ci=? #A #a)
returns
#t
.
-
-
R5 RS procedure
+
@@ -7824,17 +7935,18 @@
4.6. Characters
and carriage return.
-
-
R5 RS procedure
+
@@ -7870,17 +7982,18 @@
4.6. Characters
number between 0 and #xFF.
-
-
R5 RS procedure
+
@@ -7891,15 +8004,16 @@
4.6. Characters
lower case.
-
-
STklos procedure
+
@@ -7911,15 +8025,16 @@
4.6. Characters
does not exist.
-
-
R7 RS procedure
+
@@ -8042,15 +8157,16 @@
4.7. Strings
-
-
R5 RS procedure
+
@@ -8058,16 +8174,17 @@
4.7. Strings
Returns #t
if obj
is a string, otherwise returns #f
.
-
-
R5 RS procedure
+
@@ -8077,15 +8194,16 @@
4.7. Strings
the contents of the string are unspecified.
-
-
R5 RS procedure
+
@@ -8093,15 +8211,16 @@
4.7. Strings
Returns a newly allocated string composed of the arguments.
-
-
R5 RS procedure
+
@@ -8109,15 +8228,16 @@
4.7. Strings
Returns the number of characters in the given string
.
-
-
R5 RS procedure
+
@@ -8126,15 +8246,16 @@
4.7. Strings
(
k
must be a valid index of string).
-
-
R5 RS procedure
+
@@ -8153,17 +8274,18 @@
4.7. Strings
-
-
R5 RS / R7 RS procedure
+
@@ -8186,7 +8308,8 @@
4.7. Strings
-
+
+
@@ -8195,20 +8318,20 @@
4.7. Strings
-
-
R5 RS / R7 RS procedure
+
@@ -8233,15 +8356,16 @@
4.7. Strings
-
-
R5 RS procedure
+
@@ -8260,15 +8384,16 @@
4.7. Strings
index
end
(exclusive).
-
-
R5 RS procedure
+
@@ -8277,19 +8402,20 @@
4.7. Strings
of the given strings.
-
-
R5 RS / R7 RS procedure
+
@@ -8314,17 +8440,18 @@
4.7. Strings
-
-
R5 RS / R7 RS procedure
+
@@ -8345,17 +8472,18 @@
4.7. Strings
-
-
R7 RS procedure
+
@@ -8374,16 +8502,17 @@
4.7. Strings
than
(- end start)
.
-
-
STklos procedure
+
@@ -8401,16 +8530,17 @@
4.7. Strings
-
-
STklos procedure
+
@@ -8438,15 +8568,16 @@
4.7. Strings
-
-
STklos procedure
+
@@ -8454,17 +8585,18 @@
4.7. Strings
Returns #t
if str1
appears somewhere in str2
; otherwise returns #f
.
-
-
R7 RS procedure
+
@@ -8484,15 +8616,16 @@
4.7. Strings
-
-
STklos procedure
+
@@ -8513,15 +8646,16 @@
4.7. Strings
-
-
STklos procedure
+
@@ -8558,17 +8692,18 @@
4.7. Strings
-
-
R7 RS procedure
+
@@ -8598,17 +8733,18 @@
4.7. Strings
-
-
STklos procedure
+
@@ -8622,17 +8758,18 @@
4.7. Strings
-
-
R7 RS procedure
+
@@ -8655,17 +8792,18 @@
4.7. Strings
-
-
STklos procedure
+
@@ -8673,17 +8811,18 @@
4.7. Strings
This is the in-place side-effecting variant of string-upcase
.
-
-
STklos procedure
+
@@ -8708,17 +8847,18 @@
4.7. Strings
-
-
STklos procedure
+
@@ -8727,15 +8867,16 @@
4.7. Strings
-
-
STklos procedure
+
@@ -8760,17 +8901,18 @@
4.7. Strings
-
-
STklos procedure
+
@@ -8805,17 +8947,18 @@
4.7. Strings
-
-
R7 RS procedure
+
@@ -8838,17 +8981,18 @@
4.7. Strings
-
-
STklos procedure
+
@@ -8900,15 +9044,16 @@
4.8. Vectors
-
-
R5 RS procedure
+
@@ -8916,16 +9061,17 @@
4.8. Vectors
Returns #t
if obj
is a vector, otherwise returns #f
.
-
-
R5 RS procedure
+
@@ -8935,15 +9081,16 @@
4.8. Vectors
contents of each element is unspecified.
-
-
R5 RS procedure
+
@@ -8957,15 +9104,16 @@
4.8. Vectors
-
-
R5 RS procedure
+
@@ -8973,15 +9121,16 @@
4.8. Vectors
Returns the number of elements in vector
as an exact integer.
-
-
R5 RS procedure
+
@@ -9001,15 +9150,16 @@
4.8. Vectors
-
-
R5 RS procedure
+
@@ -9027,19 +9177,20 @@
4.8. Vectors
-
-
R5 RS / R7 RS procedure
+
@@ -9072,21 +9223,22 @@
4.8. Vectors
-
-
R7 RS procedure
+
@@ -9110,15 +9262,16 @@
4.8. Vectors
-
-
R5 RS procedure
+
@@ -9132,17 +9285,18 @@
4.8. Vectors
-
-
R5 RS / R7 RS procedure
+
@@ -9163,17 +9317,18 @@
4.8. Vectors
-
-
R5 RS / R7 RS procedure
+
@@ -9197,31 +9352,33 @@
4.8. Vectors
-
-
R7 RS procedure
+
-
-
STklos procedure
+
@@ -9232,15 +9389,16 @@
4.8. Vectors
new cells is
void .
-
-
STklos procedure
+
@@ -9256,15 +9414,16 @@
4.8. Vectors
-
-
STklos procedure
+
@@ -9298,15 +9457,16 @@
4.9. Structures
to build and access the internals of a structure.
-
-
STklos syntax
+
@@ -9348,15 +9508,16 @@
4.9. Structures
-
-
STklos procedure
+
@@ -9372,15 +9533,16 @@
4.9. Structures
to the ones of the super type.
-
-
STklos procedure
+
@@ -9394,15 +9556,16 @@
4.9. Structures
-
-
STklos procedure
+
@@ -9418,15 +9581,16 @@
4.9. Structures
-
-
STklos procedure
+
@@ -9435,15 +9599,16 @@
4.9. Structures
or
#f
otherwise.
-
-
STklos procedure
+
@@ -9451,15 +9616,16 @@
4.9. Structures
Returns the name associated to the structure type structype
.
-
-
STklos procedure
+
@@ -9489,15 +9655,16 @@
4.9. Structures
-
-
STklos procedure
+
@@ -9508,15 +9675,16 @@
4.9. Structures
the special
void value.
-
-
STklos procedure
+
@@ -9531,15 +9699,16 @@
4.9. Structures
-
-
STklos procedure
+
@@ -9547,15 +9716,16 @@
4.9. Structures
Returns the structure type of the s
structure
-
-
STklos procedure
+
@@ -9573,15 +9743,16 @@
4.9. Structures
-
-
STklos procedure
+
@@ -9599,15 +9770,16 @@
4.9. Structures
-
-
STklos procedure
+
@@ -9629,15 +9801,16 @@
4.9. Structures
-
-
STklos procedure
+
@@ -9680,15 +9853,16 @@
4.10. Bytevectors
need to be quoted in programs.
-
-
R7 RS procedure
+
@@ -9696,16 +9870,17 @@
4.10. Bytevectors
Returns #t
if obj
is a bytevector and returns #f
otherwise.
-
-
R7 RS procedure
+
@@ -9721,15 +9896,16 @@
4.10. Bytevectors
-
-
R7 RS procedure
+
@@ -9743,15 +9919,16 @@
4.10. Bytevectors
-
-
R7 RS procedure
+
@@ -9759,15 +9936,16 @@
4.10. Bytevectors
Returns the length of bytevector
in bytes as an exact integer.
-
-
R7 RS procedure
+
@@ -9781,15 +9959,16 @@
4.10. Bytevectors
-
-
STklos procedure
+
@@ -9805,17 +9984,18 @@
4.10. Bytevectors
-
-
R7 RS procedure
+
@@ -9830,17 +10010,18 @@
4.10. Bytevectors
-
-
R7 RS procedure
+
@@ -9867,15 +10048,16 @@
4.10. Bytevectors
-
-
R5 RS procedure
+
@@ -9890,21 +10072,22 @@
4.10. Bytevectors
-
-
R7 RS procedure
+
@@ -9931,15 +10114,16 @@
4.10. Bytevectors
4.11. Control features
-
-
R5 RS procedure
+
@@ -9956,15 +10140,16 @@
4.11. Control features
-
-
R5 RS procedure
+
@@ -9993,15 +10178,16 @@
4.11. Control features
-
-
R5 RS procedure
+
@@ -10030,15 +10216,16 @@
4.11. Control features
-
-
R7 RS procedure
+
@@ -10073,15 +10260,16 @@
4.11. Control features
-
-
R7 RS procedure
+
@@ -10117,15 +10305,16 @@
4.11. Control features
-
-
R5 RS procedure
+
@@ -10146,15 +10335,16 @@
4.11. Control features
-
-
R7 RS procedure
+
@@ -10178,15 +10368,16 @@
4.11. Control features
-
-
R7 RS procedure
+
@@ -10210,15 +10401,16 @@
4.11. Control features
-
-
STklos procedure
+
@@ -10249,15 +10441,16 @@
4.11. Control features
general value.
-
-
STklos procedure
+
@@ -10292,17 +10485,18 @@
4.11. Control features
-
-
R5 RS procedure
+
@@ -10407,15 +10601,16 @@
4.11. Control features
-
-
STklos procedure
+
@@ -10438,15 +10633,16 @@
4.11. Control features
-
-
R5 RS procedure
+
@@ -10469,15 +10665,16 @@
4.11. Control features
-
-
R5 RS procedure
+
@@ -10496,15 +10693,16 @@
4.11. Control features
-
-
STklos syntax
+
@@ -10557,15 +10755,16 @@
4.11. Control features
-
-
R5 RS procedure
+
@@ -10649,16 +10848,17 @@
4.11. Control features
-
-
R5 RS procedure
+
@@ -10684,15 +10884,16 @@
4.11. Control features
-
-
R7 RS procedure
+
@@ -10731,16 +10932,17 @@
4.11. Control features
-
-
R5 RS procedure
+
@@ -10762,16 +10964,17 @@
4.11. Control features
-
-
R5 RS procedure
+
@@ -10794,15 +10997,16 @@
4.11. Control features
-
-
R5 RS procedure
+
@@ -10812,16 +11016,17 @@
4.11. Control features
is mutable.
-
-
STklos procedure
+
@@ -10880,15 +11085,16 @@
4.12.1. Ports
-
-
R7 RS procedure
+
@@ -10904,17 +11110,18 @@
4.12.1. Ports
It is an error if proc does not accept one argument.
-
-
R5 RS procedure
+
@@ -10945,15 +11152,16 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -10971,15 +11179,16 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -10996,17 +11205,18 @@
4.12.1. Ports
-
-
R5 RS procedure
+
@@ -11015,17 +11225,18 @@
4.12.1. Ports
otherwise returns
#f
.
-
-
R7 RS procedure
+
@@ -11034,15 +11245,16 @@
4.12.1. Ports
otherwise returns
#f
.
-
-
R7 RS procedure
+
@@ -11051,17 +11263,18 @@
4.12.1. Ports
otherwise returns
#f
.
-
-
STklos procedure
+
@@ -11070,17 +11283,18 @@
4.12.1. Ports
respectively, otherwise returns
#f
.
-
-
STklos procedure
+
@@ -11089,17 +11303,18 @@
4.12.1. Ports
respectively, otherwise returns
#f
.
-
-
STklos procedure
+
@@ -11108,17 +11323,18 @@
4.12.1. Ports
otherwise returns
#f
.
-
-
R7 RS procedure
+
@@ -11127,17 +11343,18 @@
4.12.1. Ports
input or output, respectively, and
#f
otherwise.
-
-
STklos procedure
+
@@ -11146,15 +11363,16 @@
4.12.1. Ports
respectively, otherwise returns
#f
.
-
-
STklos procedure
+
@@ -11162,17 +11380,18 @@
4.12.1. Ports
Returns #t
if port
is connected to a terminal and #f
otherwise.
-
-
R5 RS procedure
+
@@ -11180,15 +11399,16 @@
4.12.1. Ports
Returns the current default input or output port.
-
-
STklos procedure
+
@@ -11196,17 +11416,18 @@
4.12.1. Ports
Returns the current default error port.
-
-
R5 RS procedure
+
@@ -11250,15 +11471,16 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11267,15 +11489,16 @@
4.12.1. Ports
current error port instead of the output port.
-
-
STklos procedure
+
@@ -11292,15 +11515,16 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11317,19 +11541,20 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11340,15 +11565,16 @@
4.12.1. Ports
of string specifying a file name
-
-
R5 RS procedure
+
@@ -11373,15 +11599,16 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11390,15 +11617,16 @@
4.12.1. Ports
str
.
-
-
R7 RS procedure
+
@@ -11407,15 +11635,16 @@
4.12.1. Ports
delivers bytes from the
bytevector
.
-
-
STklos procedure
+
@@ -11460,15 +11689,16 @@
4.12.1. Ports
-
-
R5 RS procedure
+
@@ -11494,15 +11724,16 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11510,15 +11741,16 @@
4.12.1. Ports
Returns an output string port capable of receiving and collecting characters.
-
-
R7 RS procedure
+
@@ -11527,15 +11759,16 @@
4.12.1. Ports
for retrieval by
get-output-bytevector
.
-
-
STklos procedure
+
@@ -11601,15 +11834,16 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11654,15 +11888,16 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11678,15 +11913,16 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11703,17 +11939,18 @@
4.12.1. Ports
-
-
R5 RS procedure
+
@@ -11723,15 +11960,16 @@
4.12.1. Ports
port has already been closed. The value returned is
void .
-
-
R7 RS procedure
+
@@ -11739,15 +11977,16 @@
4.12.1. Ports
Closes the port associated with port
.
-
-
STklos procedure
+
@@ -11756,16 +11995,17 @@
4.12.1. Ports
port-rewind
is
void .
-
-
STklos procedure
+
@@ -11792,16 +12032,17 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11826,16 +12067,17 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11846,15 +12088,16 @@
4.12.1. Ports
the value returned by
current-input-port
.
-
-
STklos procedure
+
@@ -11862,19 +12105,20 @@
4.12.1. Ports
Returns the file name used to open port
; port
must be a file port.
-
-
STklos procedure
+
@@ -11901,17 +12145,18 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11935,15 +12180,16 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11965,15 +12211,16 @@
4.12.1. Ports
-
-
STklos procedure
+
@@ -11984,16 +12231,17 @@
4.12.1. Ports
The following procedures are defined in *link:http://srfi.schemers.org/srfi-192/srfi-192.html[SRFI-192]* (_Port Positioning_)(((SRFI-192))) which is fully
supported:((("SRFI-192")))
++++<a id='P_port-has-port-position?'></a>+++
(((port-has-port-position?)))
-
-
STklos procedure
+
@@ -12003,15 +12251,16 @@
4.12.1. Ports
does not support the operation, port-position signals an error.
-
-
STklos procedure
+
@@ -12026,15 +12275,16 @@
4.12.1. Ports
away.
-
-
STklos procedure
+
@@ -12043,15 +12293,16 @@
4.12.1. Ports
the set-port-position! operation, and
#f
otherwise.
-
-
STklos procedure
+
@@ -12084,15 +12335,16 @@
4.12.1. Ports
extension, an error satisfying
i/o-invalid-position-error?
is signaled.
-
-
STklos procedure
+
@@ -12101,15 +12353,16 @@
4.12.1. Ports
The pos argument represents a position passed to set-position!.
-
-
STklos procedure
+
@@ -12123,16 +12376,17 @@
4.12.1. Ports
-
-
R5 RS procedure
+
@@ -12161,18 +12415,19 @@
-
-
STklos procedure
+
@@ -12184,15 +12439,16 @@
-
-
STklos procedure
+
@@ -12209,16 +12465,17 @@
-
-
R5 RS procedure
+
@@ -12229,17 +12486,18 @@
it defaults to the value returned by
current-input-port
.
-
-
STklos procedure
+
@@ -12264,16 +12522,17 @@
-
-
R7 RS procedure
+
@@ -12285,18 +12544,19 @@
an end-of-file object is returned.
-
-
R7 RS procedure
+
@@ -12310,17 +12570,18 @@
If no bytes are available, an end-of-file object is returned.
-
-
STklos procedure
+
@@ -12367,16 +12628,17 @@
-
-
STklos procedure
+
@@ -12386,16 +12648,17 @@
object.
-
-
R5 RS procedure
+
@@ -12424,16 +12687,17 @@
-
-
STklos procedure
+
@@ -12443,15 +12707,16 @@
returns a character, this function returns an integer between 0and 255.
-
-
R5 RS procedure
+
@@ -12459,15 +12724,16 @@
Returns #t
if obj
is an end of file object, otherwise returns #f
.
-
-
STklos procedure
+
@@ -12478,16 +12744,17 @@
another way to return such an end of file object.
-
-
R5 RS procedure
+
@@ -12499,16 +12766,17 @@
defaults to the value returned by
current-input-port
.
-
-
R7 RS procedure
+
@@ -12520,16 +12788,17 @@
an end-of-file object is returned.
-
-
R7 RS procedure
+
@@ -12552,16 +12821,17 @@
-
-
R7 RS procedure
+
@@ -12585,16 +12855,17 @@
-
-
R7 RS procedure
+
@@ -12606,16 +12877,17 @@
returns
#t
.
-
-
STklos procedure
+
@@ -12643,15 +12915,16 @@
-
-
STklos procedure
+
@@ -12666,19 +12939,20 @@
-
-
STklos procedure
+
@@ -12701,16 +12975,17 @@
4.12.3. Output
-
-
R5 RS procedure
+
@@ -12723,17 +12998,18 @@
4.12.3. Output
which case it defaults to the value returned by
current-output-port
.
-
-
R7 RS procedure
+
@@ -12760,20 +13036,21 @@
4.12.3. Output
-
-
STklos procedure
+
@@ -12785,16 +13062,17 @@
4.12.3. Output
write-with-shared-structure
.
-
-
R5 RS procedure
+
@@ -12834,16 +13112,17 @@
4.12.3. Output
-
-
STklos procedure
+
@@ -12852,16 +13131,17 @@
4.12.3. Output
that shared structure are represented using datum labels.
-
-
STklos procedure
+
@@ -12872,16 +13152,17 @@
4.12.3. Output
contains circular structure.
-
-
R5 RS procedure
+
@@ -12892,18 +13173,19 @@
4.12.3. Output
by
current-output-port
.
-
-
R7 RS procedure
+
@@ -12912,16 +13194,17 @@
4.12.3. Output
left-to-right order to the textual output
port
.
-
-
R7 RS procedure
+
@@ -12929,18 +13212,19 @@
4.12.3. Output
Writes the byte
to the given binary output port.
-
-
R7 RS procedure
+
@@ -12949,16 +13233,17 @@
4.12.3. Output
left-to-right order to the binary output
port
.
-
-
R5 RS procedure
+
@@ -12969,16 +13254,17 @@
4.12.3. Output
value returned by
current-output-port
.
-
-
STklos procedure
+
@@ -13003,16 +13289,17 @@
4.12.3. Output
-
-
STklos procedure
+
@@ -13024,16 +13311,17 @@
4.12.3. Output
-
-
STklos procedure
+
@@ -13164,16 +13452,17 @@
4.12.3. Output
-
-
STklos procedure
+
@@ -13183,17 +13472,18 @@
4.12.3. Output
returned by
current-output-port
-
-
STklos procedure
+
@@ -13203,19 +13493,20 @@
4.12.3. Output
current error port
-
-
STklos procedure
+
@@ -13247,15 +13538,16 @@
4.13.1. Loading code
-
-
R5 RS procedure
+
@@ -13274,15 +13566,16 @@
4.13.1. Loading code
with the suffixes given by
"load-suffixes"
.
-
-
STklos procedure
+
@@ -13294,17 +13587,18 @@
4.13.1. Loading code
#t
. Otherwise,
try-load
retuns
#f
.
-
-
STklos procedure
+
@@ -13332,37 +13626,39 @@
4.13.1. Loading code
-
-
STklos procedure
+
-
Returns the path of the file that is currently being load.
+
Returns the path of the file that is currently being loaded.
-
-
STklos procedure
+
@@ -13378,16 +13674,17 @@
4.13.1. Loading code
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -13401,17 +13698,18 @@
4.13.2. File Primitives
This parameter object is also defined in SRFI-170 (POSIX API ).
-
-
STklos procedure
+
@@ -13461,16 +13759,17 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -13480,15 +13779,16 @@
4.13.2. File Primitives
defaults to the result of invoking
temp-file-prefix
.
-
-
STklos procedure
+
@@ -13500,16 +13800,17 @@
4.13.2. File Primitives
This function is also defined in SRFI-170 (POSIX API ).
-
-
R7 RS procedure
+
@@ -13522,15 +13823,16 @@
4.13.2. File Primitives
reasons. ,(index "remove-file")
-
-
STklos procedure
+
@@ -13540,16 +13842,17 @@
4.13.2. File Primitives
the call to
copy-file
is lost. The result of
copy-file
is
void .
-
-
STklos procedure
+
@@ -13561,15 +13864,16 @@
4.13.2. File Primitives
which are copied from
in
to
out
.
-
-
R7 RS procedure
+
@@ -13578,23 +13882,24 @@
4.13.2. File Primitives
returns
#f
otherwise.
-
-
STklos procedure
+
@@ -13604,15 +13909,16 @@
4.13.2. File Primitives
which does not exist).
-
-
STklos procedure
+
@@ -13622,15 +13928,16 @@
4.13.2. File Primitives
file-size
returns
#f
.
-
-
STklos procedure
+
@@ -13638,16 +13945,17 @@
4.13.2. File Primitives
Returns a string containing the current working directory.
-
-
STklos procedure
+
@@ -13665,15 +13973,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -13681,17 +13990,18 @@
4.13.2. File Primitives
Changes the current directory to the directory given in string dir
.
-
-
STklos procedure
+
@@ -13713,16 +14023,17 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -13745,15 +14056,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -13762,17 +14074,18 @@
4.13.2. File Primitives
does not exist yet.
-
-
STklos procedure
+
@@ -13793,16 +14106,17 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -13817,15 +14131,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -13842,15 +14157,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -13861,15 +14177,16 @@
4.13.2. File Primitives
returns
#f
.
-
-
STklos procedure
+
@@ -13887,15 +14204,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -13915,15 +14233,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -13941,15 +14260,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -13963,15 +14283,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -13985,15 +14306,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -14010,15 +14332,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -14032,15 +14355,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -14049,15 +14373,16 @@
4.13.2. File Primitives
#/
on Unix (or Cygwin) systems and
#\
on Windows.
-
-
STklos procedure
+
@@ -14071,15 +14396,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -14140,15 +14466,16 @@
4.13.2. File Primitives
-
-
STklos procedure
+
@@ -14160,15 +14487,16 @@
4.13.2. File Primitives
This function is defined in SRFI-170 (POSIX API ).
-
-
STklos procedure
+
@@ -14182,15 +14510,16 @@
4.13.2. File Primitives
This function is defined in SRFI-170 (POSIX API ).
-
-
STklos procedure
+
@@ -14203,15 +14532,16 @@
4.13.2. File Primitives
This function is defined in SRFI-170 (POSIX API ).
-
-
STklos procedure
+
@@ -14219,15 +14549,16 @@
4.13.2. File Primitives
This procedure returns the value of errno
(an exact integer).
-
-
STklos procedure
+
@@ -14236,15 +14567,16 @@
4.13.2. File Primitives
the error.
-
-
STklos procedure
+
@@ -14256,16 +14588,17 @@
4.13.2. File Primitives
4.13.3. Environment
-
-
STklos procedure
+
@@ -14285,15 +14618,16 @@
4.13.3. Environment
-
-
STklos procedure
+
@@ -14302,15 +14636,16 @@
4.13.3. Environment
value
must be strings. The result of
setenv!
is
void .
-
-
STklos procedure
+
@@ -14324,15 +14659,16 @@
4.13.3. Environment
primivitives to acess environment variables.
-
-
R7 RS procedure
+
@@ -14343,15 +14679,16 @@
4.13.3. Environment
has been added to be support
SRFI-98 (
Interface to access environment variables ).
-
-
R7 RS procedure
+
@@ -14360,16 +14697,17 @@
4.13.3. Environment
This function is defined by
SRFI-98 (
Interface to access environment variables ).
-
-
STklos procedure
+
@@ -14389,19 +14727,60 @@
4.13.3. Environment
( build-path-from-shell-variable "MYPATH" "/:" ) => ( "bin" "sbin" "usr" "bin" )
+
+
+
+
+
Returns the list of the installation directories chosen when STklos was
+configured. Without parameter, install-path
returns the path of all
+configured directories. When key
is provided, only the corresponding path is
+returned. Key
can be:
+
+
+
+
+#:libdir
(directory for architecture specific installed files)
+
+
+#:datadir
(directory for portable installed files)
+
+
+#:docdir
(directory for installed documentation)
+
+
+#:htmldir
(directory for installed HTML documentation)
+
+
+#:pdfdir
(directory for installed PDF documentation)
+
+
+
4.13.4. Time
-
-
R7 RS procedure
+
@@ -14413,15 +14792,16 @@
4.13.4. Time
second later.
-
-
R7 RS procedure
+
@@ -14435,15 +14815,16 @@
4.13.4. Time
but may vary between runs.
-
-
R7 RS procedure
+
@@ -14462,15 +14843,16 @@
4.13.4. Time
-
-
STklos procedure
+
@@ -14479,15 +14861,16 @@
4.13.4. Time
program.
-
-
STklos procedure
+
@@ -14497,15 +14880,16 @@
4.13.4. Time
signal arrives during the pause, the execution may be resumed.
-
-
STklos syntax
+
@@ -14519,15 +14903,16 @@
4.13.4. Time
-
-
R7 RS procedure
+
@@ -14538,20 +14923,25 @@
+<<<<<<< HEAD
( features ) => ( STklos STklos-2 . 00.20 exact-complex
+=======
+( features ) => ( STklos STklos-2 . 00.82 exact-complex
+>>>>>>> v210-enhance
ieee-float full-unicode ratios little-endian ... )
-
-
STklos procedure
+
@@ -14562,15 +14952,16 @@
returns either
unix
,
android
,
windows
, or
cygwin-windows
.
-
-
STklos procedure
+
@@ -14578,15 +14969,16 @@
Return the host name of the current processor as a string.
-
-
R7 RS procedure
+
@@ -14596,15 +14988,16 @@
name.
-
-
STklos procedure
+
@@ -14613,17 +15006,18 @@
otherwise. This function is defined in
SRFI-193 (
Command line ).
-
-
STklos procedure
+
@@ -14633,15 +15027,16 @@
deprecated and should not be used.
-
-
STklos procedure
+
@@ -14649,15 +15044,16 @@
Returns the number of arguments present on the command line.
-
-
STklos procedure
+
@@ -14669,15 +15065,16 @@
#f
when the program name is not a script.
-
-
STklos procedure
+
@@ -14687,15 +15084,16 @@
This function is defined in
SRFI-193 (
Command line ).
-
-
STklos procedure
+
@@ -14704,17 +15102,18 @@
As with
script-file
, this is an absolute pathname.
-
-
STklos procedure
+
@@ -14730,15 +15129,16 @@
this function.
-
-
STklos procedure
+
@@ -14747,15 +15147,16 @@
its eventual patch number.
-
-
STklos procedure
+
@@ -14765,15 +15166,16 @@
[os-name]-[os-version]-[cpu-architecture]
.
-
-
STklos procedure
+
@@ -14782,15 +15184,16 @@
implementation (i.e. the string
"STklos"
).
-
-
STklos procedure
+
@@ -14800,15 +15203,16 @@
is executing.
-
-
STklos procedure
+
@@ -14817,15 +15221,16 @@
particular machine on which the implementation is running.
-
-
STklos procedure
+
@@ -14835,15 +15240,16 @@
implementation is running.
-
-
STklos procedure
+
@@ -14853,15 +15259,16 @@
implementation is running.
-
-
STklos procedure
+
@@ -14880,15 +15287,16 @@
4.13.6. Program Arguments Parsing
use a
main
function in a Scheme program.
-
-
STklos procedure
+
@@ -15066,16 +15474,17 @@
4.13.6. Program Arguments Parsing
-
-
STklos procedure
+
@@ -15091,15 +15500,16 @@
4.13.6. Program Arguments Parsing
4.13.7. Misc. System Procedures
-
-
STklos procedure
+
@@ -15108,17 +15518,18 @@
4.13.7. Misc. System Procedures
system
is the integer status code the shell returns.
-
-
STklos procedure
+
@@ -15136,15 +15547,16 @@
4.13.7. Misc. System Procedures
-
-
STklos procedure
+
@@ -15152,16 +15564,17 @@
4.13.7. Misc. System Procedures
Returns the address of the object obj
as an integer.
-
-
STklos procedure
+
@@ -15185,16 +15598,17 @@
4.13.7. Misc. System Procedures
-
-
STklos procedure
+
@@ -15217,16 +15631,17 @@
4.13.7. Misc. System Procedures
-
-
STklos procedure
+
@@ -15236,15 +15651,16 @@
4.13.7. Misc. System Procedures
defaults to 1.
-
-
STklos procedure
+
@@ -15254,15 +15670,16 @@
4.13.7. Misc. System Procedures
password as a string.
-
-
STklos procedure
+
@@ -15306,15 +15723,16 @@
4.14. Keywords
information.
-
-
STklos procedure
+
@@ -15333,15 +15751,16 @@
4.14. Keywords
-
-
STklos procedure
+
@@ -15357,15 +15776,16 @@
4.14. Keywords
-
-
STklos procedure
+
@@ -15373,15 +15793,16 @@
4.14. Keywords
Returns the name of key
as a string. The result does not contain a colon.
-
-
STklos procedure
+
@@ -15391,16 +15812,17 @@
4.14. Keywords
a symbol.
-
-
STklos procedure
+
@@ -15420,15 +15842,16 @@
4.14. Keywords
-
-
STklos procedure
+
@@ -15447,17 +15870,18 @@
4.14. Keywords
-
-
STklos procedure
+
@@ -15480,16 +15904,17 @@
4.14. Keywords
-
-
STklos procedure
+
@@ -15552,17 +15977,18 @@
4.15. Hash Tables
SRFI’s documentation for more information.
-
-
STklos procedure
+
@@ -15650,15 +16076,16 @@
4.15. Hash Tables
-
-
STklos procedure
+
@@ -15669,15 +16096,16 @@
4.15. Hash Tables
-
-
STklos procedure
+
@@ -15695,17 +16123,18 @@
4.15. Hash Tables
modeled.
-
-
STklos procedure
+
@@ -15718,15 +16147,16 @@
4.15. Hash Tables
association will take precedence over later ones.
-
-
STklos procedure
+
@@ -15758,15 +16188,16 @@
4.15. Hash Tables
-
-
STklos procedure
+
@@ -15775,16 +16206,17 @@
4.15. Hash Tables
The value returned by
hash-table-set!
is
void .
-
-
STklos procedure
+
@@ -15811,15 +16243,16 @@
4.15. Hash Tables
-
-
STklos procedure
+
@@ -15832,15 +16265,16 @@
4.15. Hash Tables
-
-
STklos procedure
+
@@ -15859,15 +16293,16 @@
4.15. Hash Tables
-
-
STklos procedure
+
@@ -15876,17 +16311,18 @@
4.15. Hash Tables
hash
. Returns
#f
otherwise.
-
-
STklos procedure
+
@@ -15922,17 +16358,18 @@
4.15. Hash Tables
-
-
STklos procedure
+
@@ -15979,15 +16416,16 @@
4.15. Hash Tables
-
-
STklos procedure
+
@@ -16021,17 +16459,18 @@
4.15. Hash Tables
-
-
STklos procedure
+
@@ -16039,15 +16478,16 @@
4.15. Hash Tables
Returns the keys or the values of hash
.
-
-
STklos procedure
+
@@ -16073,15 +16513,16 @@
4.15. Hash Tables
computes the number of associations present in the ht
hash table.
-
-
STklos procedure
+
@@ -16089,15 +16530,16 @@
4.15. Hash Tables
Returns a copy of hash
.
-
-
STklos procedure
+
@@ -16106,15 +16548,16 @@
4.15. Hash Tables
hash table. This function may modify
hash1
destructively.
-
-
STklos procedure
+
@@ -16122,15 +16565,16 @@
4.15. Hash Tables
Returns the equivalence predicate used for keys in hash
.
-
-
STklos procedure
+
@@ -16138,15 +16582,16 @@
4.15. Hash Tables
Returns the hash function used for keys in hash
.
-
-
STklos procedure
+
@@ -16156,15 +16601,16 @@
4.15. Hash Tables
hash table.
-
-
STklos procedure
+
@@ -16173,15 +16619,16 @@
4.15. Hash Tables
an error.
-
-
STklos procedure
+
@@ -16189,16 +16636,17 @@
4.15. Hash Tables
Returns the number of entries in the hash
.
-
-
STklos procedure
+
@@ -16220,15 +16668,16 @@
4.16. Dates and Times
also be represented with date structures.
-
-
R7 RS procedure
+
@@ -16240,15 +16689,16 @@
4.16. Dates and Times
second later.
-
-
STklos procedure
+
@@ -16272,16 +16722,17 @@
4.16. Dates and Times
-
-
STklos procedure
+
@@ -16303,16 +16754,17 @@
4.16. Dates and Times
-
-
STklos procedure
+
@@ -16337,25 +16789,26 @@
4.16. Dates and Times
-
-
STklos procedure
+
@@ -16363,15 +16816,16 @@
4.16. Dates and Times
These are accessors for time structures.
-
-
STklos procedure
+
@@ -16379,15 +16833,16 @@
4.16. Dates and Times
Return #t
if obj
is a time object, othererwise returns #f
.
-
-
STklos procedure
+
@@ -16401,15 +16856,16 @@
4.16. Dates and Times
-
-
STklos procedure
+
@@ -16424,17 +16880,18 @@
4.16. Dates and Times
-
-
STklos procedure
+
@@ -16447,17 +16904,18 @@
4.16. Dates and Times
can use
t
to build the returned object.
-
-
STklos procedure
+
@@ -16470,15 +16928,16 @@
4.16. Dates and Times
can use
t
to build the returned object.
-
-
STklos procedure
+
@@ -16486,16 +16945,17 @@
4.16. Dates and Times
Returns the current system date.
-
-
STklos procedure
+
@@ -16504,15 +16964,16 @@
4.16. Dates and Times
default to 0;
day
and
month
default to 1;
year
defaults to 1970.
-
-
STklos procedure
+
@@ -16520,15 +16981,16 @@
4.16. Dates and Times
Return #t
if obj
is a date, and otherwise returns #f
.
-
-
STklos procedure
+
@@ -16536,15 +16998,16 @@
4.16. Dates and Times
Return the nanosecond of date d
.
-
-
STklos procedure
+
@@ -16552,15 +17015,16 @@
4.16. Dates and Times
Return the second of date d
, in the range 0 to 59.
-
-
STklos procedure
+
@@ -16568,15 +17032,16 @@
4.16. Dates and Times
Return the minute of date d
, in the range 0 to 59.
-
-
STklos procedure
+
@@ -16584,15 +17049,16 @@
4.16. Dates and Times
Return the hour of date d
, in the range 0 to 23.
-
-
STklos procedure
+
@@ -16600,15 +17066,16 @@
4.16. Dates and Times
Return the day of date d
, in the range 1 to 31
-
-
STklos procedure
+
@@ -16616,15 +17083,16 @@
4.16. Dates and Times
Return the month of date d
, in the range 1 to 12
-
-
STklos procedure
+
@@ -16632,15 +17100,16 @@
4.16. Dates and Times
Return the year of date d
.
-
-
STklos procedure
+
@@ -16648,15 +17117,16 @@
4.16. Dates and Times
Return the week day of date d
, in the range 0 to 6 (0 is Sunday).
-
-
STklos procedure
+
@@ -16665,15 +17135,16 @@
4.16. Dates and Times
1 to 366.
-
-
STklos procedure
+
@@ -16694,15 +17165,16 @@
4.16. Dates and Times
-
-
STklos procedure
+
@@ -16710,15 +17182,16 @@
4.16. Dates and Times
Return the time zone of date d
.
-
-
STklos procedure
+
@@ -16740,15 +17213,16 @@
4.16. Dates and Times
variable does not appear in the environment, the system timezone is used.
-
-
STklos procedure
+
@@ -16762,16 +17236,17 @@
4.16. Dates and Times
-
-
STklos procedure
+
@@ -16782,15 +17257,16 @@
4.16. Dates and Times
If
format
is omitted, it defaults to
"~c"
.
-
-
STklos procedure
+
@@ -16808,15 +17284,16 @@
4.16. Dates and Times
-
-
STklos procedure
+
@@ -16942,15 +17419,16 @@
4.16. Dates and Times
-
-
STklos procedure
+
@@ -17005,15 +17483,16 @@
4.16. Dates and Times
-
-
STklos procedure
+
@@ -17039,17 +17518,18 @@
4.17. Boxes
Note that two boxes are equal?
iff their content are equal?
.
-
-
STklos procedure
+
@@ -17076,17 +17556,18 @@
4.17. Boxes
-
-
STklos procedure
+
@@ -17106,15 +17587,16 @@
4.17. Boxes
-
-
STklos procedure
+
@@ -17122,15 +17604,16 @@
4.17. Boxes
Returns #t
if obj
is a box, #f
otherwise.
-
-
STklos procedure
+
@@ -17138,17 +17621,18 @@
4.17. Boxes
Returns #t
if obj
is a mutable box, #f
otherwise.
-
-
STklos procedure
+
@@ -17162,15 +17646,16 @@
4.17. Boxes
The name box-set!
is now obsolete and kept only for compatibility.
-
-
STklos procedure
+
@@ -17178,15 +17663,16 @@
4.17. Boxes
Returns the values currently in box
.
-
-
STklos procedure
+
@@ -17194,15 +17680,16 @@
4.17. Boxes
Returns the number of values in box
.
-
-
STklos procedure
+
@@ -17211,15 +17698,16 @@
4.17. Boxes
between 0 and
n
-1, when
n
is the number of values in
box
.
-
-
STklos procedure
+
@@ -17239,15 +17727,16 @@
4.18. Processes
the standard files of the process are redirected, …
-
-
STklos procedure
+
@@ -17312,15 +17801,16 @@
4.18. Processes
-
-
STklos procedure
+
@@ -17328,15 +17818,16 @@
4.18. Processes
Returns #t
if obj
is a process , otherwise returns #f
.
-
-
STklos procedure
+
@@ -17344,15 +17835,16 @@
4.18. Processes
Returns #t
if process proc
is currently running, otherwise returns #f
.
-
-
STklos procedure
+
@@ -17361,19 +17853,20 @@
4.18. Processes
processus.
-
-
STklos procedure
+
@@ -17385,15 +17878,16 @@
4.18. Processes
for writing when calling
process-input
.
-
-
STklos procedure
+
@@ -17403,15 +17897,16 @@
4.18. Processes
#t
otherwise.
-
-
STklos procedure
+
@@ -17420,15 +17915,16 @@
4.18. Processes
returns
#f
otherwise.
-
-
STklos procedure
+
@@ -17439,15 +17935,16 @@
4.18. Processes
The result of
process-send-signal
is
void .
-
-
STklos procedure
+
@@ -17461,17 +17958,18 @@
4.18. Processes
-
-
STklos procedure
+
@@ -17486,15 +17984,16 @@
4.18. Processes
-
-
STklos procedure
+
@@ -17502,16 +18001,17 @@
4.18. Processes
Returns the list of processes which are currently running (i.e. alive).
-
-
STklos procedure
+
@@ -17539,16 +18039,17 @@
4.19. Sockets
applications.
-
-
STklos procedure
+
@@ -17562,16 +18063,17 @@
4.19. Sockets
line-buffered
is
#t
.
-
-
STklos procedure
+
@@ -17581,16 +18083,17 @@
4.19. Sockets
otherwise, the communication port is chosen by the system.
-
-
STklos procedure
+
@@ -17621,16 +18124,17 @@
4.19. Sockets
-
-
STklos procedure
+
@@ -17669,15 +18173,16 @@
4.19. Sockets
also the connection to
client
.
-
-
STklos procedure
+
@@ -17685,15 +18190,16 @@
4.19. Sockets
Returns #t
if socket
is a socket, otherwise returns #f
.
-
-
STklos procedure
+
@@ -17701,15 +18207,16 @@
4.19. Sockets
Returns #t
if socket
is a server socket, otherwise returns #f
.
-
-
STklos procedure
+
@@ -17717,15 +18224,16 @@
4.19. Sockets
Returns #t
if socket
is a client socket, otherwise returns #f
.
-
-
STklos procedure
+
@@ -17739,15 +18247,16 @@
4.19. Sockets
has used yet
socket
, this function returns
#f
.
-
-
STklos procedure
+
@@ -17761,15 +18270,16 @@
4.19. Sockets
socket
, this function returns
#f
.
-
-
STklos procedure
+
@@ -17778,15 +18288,16 @@
4.19. Sockets
attached to
socket
.
-
-
STklos procedure
+
@@ -17794,17 +18305,18 @@
4.19. Sockets
Returns the integer number of the port used for socket
.
-
-
STklos procedure
+
@@ -17851,15 +18363,16 @@
4.20. Signals
you plan to port your program on another system.
-
-
STklos procedure
+
@@ -17896,15 +18409,16 @@
4.20. Signals
-
-
STklos procedure
+
@@ -17915,16 +18429,17 @@
4.20. Signals
more information.
-
-
STklos procedure
+
@@ -17934,15 +18449,16 @@
4.20. Signals
program.
-
-
STklos procedure
+
@@ -17961,16 +18477,17 @@
4.21. Parameter Objects
See SRFI document for more information.
-
-
STklos procedure
+
@@ -18022,15 +18539,35 @@
4.21. Parameter Objects
+
+
-
-
STklos procedure
+
@@ -18081,15 +18619,16 @@
4.21. Parameter Objects
4.22. Misc
-
-
STklos procedure
+
@@ -18098,16 +18637,17 @@
4.22. Misc
-
-
STklos procedure
+
@@ -18116,15 +18656,16 @@
4.22. Misc
they are evalued and simply ignored.
-
-
STklos procedure
+
@@ -18145,16 +18686,17 @@
4.22. Misc
-
-
R7 RS procedure
+
@@ -18210,16 +18752,17 @@
4.22. Misc
-
-
STklos procedure
+
@@ -18237,16 +18780,17 @@
4.22. Misc
-
-
R7 RS syntax
+
@@ -18272,17 +18816,18 @@
4.22. Misc
-
-
R7 RS procedure
+
@@ -18292,15 +18837,16 @@
4.22. Misc
output port on a file, respectively. Otherwise, it returns
#f
.
-
-
R7 RS procedure
+
@@ -18309,15 +18855,16 @@
4.22. Misc
it returns
#f
.
-
-
R7 RS procedure
+
@@ -18325,15 +18872,16 @@
4.22. Misc
Returns the message encapsulated by error-object
.
-
-
R7 RS procedure
+
@@ -18341,15 +18889,16 @@
4.22. Misc
Returns the message encapsulated by error-object
.
-
-
STklos procedure
+
@@ -18366,15 +18915,16 @@
4.22. Misc
-
-
STklos syntax
+
@@ -18448,15 +18998,16 @@
4.22. Misc
A list of available symbolic names for features is given in Chapter 13 .
-
-
STklos procedure
+
@@ -18478,36 +19029,17 @@
4.22. Misc
-
-
-
-
-
This procedure launches a new Read-Eval-Print-Loop. Calls to repl
can be
-embedded. The ports used for input/output as well as the error port can
-be passed when repl
is called. If not passed, they default to
-current-input-port
, current-output-port
and current-error-port
.
-
-
-
STklos syntax
+
@@ -18522,15 +19054,16 @@
4.22. Misc
-
-
STklos procedure
+
@@ -18539,16 +19072,17 @@
4.22. Misc
SRFI-176 (
Version flag ).
-
-
STklos procedure
+
@@ -18560,16 +19094,17 @@
4.22. Misc
provided).
-
-
STklos procedure
+
@@ -18598,15 +19133,16 @@
4.22. Misc
-
-
STklos procedure
+
@@ -18620,8 +19156,8 @@
4.22. Misc
-
( describe 5 )
- 5 is an integer .
+( describe 10 )
+ 10 is a fixnum integer number ( #xa #o12 #b1010 ) .
( describe 5.4 )
5.4 is a real .
@@ -18629,8 +19165,8 @@ 4.22. Misc
( describe 2 +3i )
2 +3i is a complex number .
-( describe # A )
- # A is a character, ascii value is 65 .
+( describe # \é )
+ # \é is a character whose Unicode code point is 233 .
@@ -18643,7 +19179,9 @@
4.22. Misc
Superclasses are:
<rational>
( No direct slot )
- ( No direct subclass )
+ Directs subclasses are:
+ <fixnum>
+ <bignum>
Class Precedence List is:
<integer>
<rational>
@@ -18677,15 +19215,92 @@ 4.22. Misc
+
+
+
+
This parameter object denotes the name of the browser used by STklos
+to open URLs. The value of this parameter is set at initialization time
+to (in that order):
+
+
+
+
+the value of the shell variable STKLOS_BROWSER
, if it is set, or
+
+
+the value of the shell variable BROWSER
, if it is set, or
+
+
+the string "open" on macOS, or "xdg-open" on other OS.
+
+
+
+
+
+
+
+
Opens the URL given by the string url
in the default browser, which is
+determined by the string contained in the parameter default-browser
.
+
+
+
+
-
-
STklos syntax
+
+
Opens the STklos manual in a browser. If the symbol or the
+string entry
is given, the manual is opened on the description
+of entry
.
+NOTE: If the HTML manual file is not installed, the documentation is
+searched on the STklos web site, which can incur a non-negligible
+response time.
+NOTE: another name for this function is man
.
+
+
+
@@ -18699,15 +19314,16 @@
4.22. Misc
Calling trace
with no argument returns the list of traced functions.
-
-
STklos syntax
+
@@ -18720,17 +19336,18 @@
4.22. Misc
currently traced.
-
-
STklos procedure
+
@@ -18744,15 +19361,16 @@
4.22. Misc
Note that
pp
is another name for
pretty-print
.
-
-
STklos procedure
+
@@ -18764,15 +19382,16 @@
4.22. Misc
returns
#f
.
-
-
STklos procedure
+
@@ -18783,15 +19402,16 @@
4.22. Misc
not available,
procedure-source
returns
#f
.
-
-
STklos procedure
+
@@ -18844,16 +19464,17 @@
4.22. Misc
will display the words BLUE and RED in color.
-
-
STklos procedure
+
@@ -18916,17 +19537,18 @@
4.22. Misc
-
-
STklos procedure
+
@@ -18962,15 +19584,16 @@
4.22. Misc
-
-
STklos procedure
+
@@ -19029,15 +19652,16 @@
4.22. Misc
-
-
STklos procedure
+
@@ -19053,15 +19677,16 @@
4.22. Misc
-
-
STklos procedure
+
@@ -19070,15 +19695,16 @@
4.22. Misc
be a string or an open input port.
-
-
STklos procedure
+
@@ -19086,16 +19712,17 @@
4.22. Misc
Return a string contening the md5 sum of the file whose name is str
.
-
-
STklos procedure
+
@@ -19113,16 +19740,17 @@
4.22. Misc
-
-
STklos procedure
+
@@ -19140,15 +19768,16 @@
4.22. Misc
-
-
STklos procedure
+
@@ -19157,15 +19786,16 @@
4.22. Misc
encoded format.
-
-
STklos procedure
+
@@ -20753,15 +21383,16 @@
5.17. Regexp Procedures
before
-
-
STklos procedure
+
@@ -20775,15 +21406,16 @@
5.17. Regexp Procedures
each time.
-
-
STklos procedure
+
@@ -20792,17 +21424,18 @@
5.17. Regexp Procedures
otherwise
regexp
returns
#f
.
-
-
STklos procedure
+
@@ -20840,17 +21473,18 @@
5.17. Regexp Procedures
-
-
STklos procedure
+
@@ -20892,15 +21526,16 @@
5.17. Regexp Procedures
-
-
STklos procedure
+
@@ -21115,15 +21750,16 @@
6.2. STklos match-lambda.
-
-
STklos syntax
+
@@ -21164,15 +21800,16 @@
6.2. STklos
-
-
STklos syntax
+
@@ -21222,15 +21859,16 @@
7.1. Exceptions
context, and this SRFI’s current exception handler.
-
-
STklos syntax
+
@@ -21251,15 +21889,16 @@
7.1. Exceptions
-
-
R7 RS procedure
+
@@ -21283,15 +21922,16 @@
7.1. Exceptions
-
-
R7 RS procedure
+
@@ -21311,15 +21951,16 @@
7.1. Exceptions
-
-
R7 RS procedure
+
@@ -21350,15 +21991,16 @@
7.1. Exceptions
-
-
R7 RS procedure
+
@@ -21396,15 +22038,16 @@
7.1. Exceptions
-
-
STklos procedure
+
@@ -21478,15 +22121,16 @@
7.2. Conditions
is a simple way to see it’s slots and their associated value.
-
-
STklos procedure
+
@@ -21497,15 +22141,16 @@
7.2. Conditions
the slots of the conditions associated with the condition type.
-
-
STklos procedure
+
@@ -21513,15 +22158,16 @@
7.2. Conditions
Returns #t
if obj
is a condition type, and #f
otherwise
-
-
STklos procedure
+
@@ -21545,15 +22191,16 @@
7.2. Conditions
-
-
STklos procedure
+
@@ -21574,15 +22221,16 @@
7.2. Conditions
-
-
STklos procedure
+
@@ -21590,15 +22238,16 @@
7.2. Conditions
Returns #t
if obj
is a condition, and #f
otherwise
-
-
STklos procedure
+
@@ -21620,15 +22269,16 @@
7.2. Conditions
-
-
STklos procedure
+
@@ -21647,15 +22297,16 @@
7.2. Conditions
-
-
STklos procedure
+
@@ -21679,15 +22330,16 @@
7.2. Conditions
-
-
STklos procedure
+
@@ -21700,15 +22352,16 @@
7.2. Conditions
the value from the first of the
conditioni
that has such a slot.
-
-
STklos procedure
+
@@ -22329,7 +22982,7 @@
Class precedence list
-
8.2.3. Generic function
+
8.2.3. Generic functions
Generic functions and methods
@@ -22494,7 +23147,7 @@
Next-method
When a generic function is called, the list of applicable
methods is built. As mentioned before, the most specific method
-of this list is applied (see
Section 8.2.3 ).
+of this list is applied (see
Section 8.2.3 ).
This method may call, if needed, the next method in the list of
@@ -22619,15 +23272,16 @@
8.3. Object System Main Func
8.3.1. Classes and Instances
-
-
STklos syntax
+
@@ -22709,18 +23363,19 @@
8.3.1. Classes and Instances
-
-
STklos procedure
+
@@ -22758,15 +23413,16 @@
8.3.1. Classes and Instances
-
-
STklos procedure
+
@@ -22781,15 +23437,16 @@
8.3.1. Classes and Instances
-
-
STklos procedure
+
@@ -22804,15 +23461,16 @@
8.3.1. Classes and Instances
-
-
STklos procedure
+
@@ -22827,16 +23485,17 @@
8.3.1. Classes and Instances
-
-
STklos procedure
+
@@ -22845,15 +23504,16 @@
8.3.1. Classes and Instances
a class instance, the
default
value is returned, if present.
-
-
STklos procedure
+
@@ -22861,15 +23521,16 @@
8.3.1. Classes and Instances
Returns #t
if obj
is an instance of class
, and #f
otherwise.
-
-
STklos procedure
+
@@ -22899,18 +23560,19 @@
8.3.2. Generic Functions and Methods
behavior which depends of the type or the number of its parameters.
-
-
STklos procedure
+
@@ -22936,15 +23598,16 @@
8.3.2. Generic Functions and Methods
-
-
STklos syntax
+
@@ -23001,15 +23664,18 @@
8.3.2. Generic Functions and Methods
The classes matched in the example are <string>
and <number>
, but any
class can be used. All Scheme types are built-in classes in STklos:
-
-
<boolean> <null>
+
+
+
<boolean> <null>
<char> <object>
<class> <pair>
<complex> <procedure>
<eof> <rational>
<integer> <real>
+<fixnum> <bignum>
<list> <symbol>
-<vector> …
+<vector> ...
+
User-defined classes can also be used (and this is the main original use case
@@ -23063,15 +23729,16 @@
8.3.2. Generic Functions and Methods
-
-
STklos procedure
+
@@ -23097,19 +23764,20 @@
8.3.2. Generic Functions and Methods
8.3.3. Misc.
-
-
STklos procedure
+
@@ -23146,17 +23814,18 @@
8.3.3. Misc.
<A>
).
Slot-two
in
<C>
can only be the one defined in
<A>
.
-
-
STklos procedure
+
@@ -23180,15 +23849,16 @@
8.3.3. Misc.
-
-
STklos procedure
+
@@ -23211,7 +23881,8 @@
8.3.3. Misc.
-
+
+
@@ -23220,20 +23891,20 @@
8.3.3. Misc.
-
-
STklos procedure
+
@@ -23252,6 +23923,16 @@
8.3.3. Misc.
=> ( # :init-form 0 # :accessor x )
+
+
+
// SPDX-License-Identifier: GFDL-1.3-or-later
+//
+// Copyright © 2000-2023 Erick Gallesio <eg@stklos.net>
+//
+// Author: Erick Gallesio [eg@unice.fr]
+// Creation date: 26-Nov-2000 18:19 (eg)
+
+
@@ -23269,12 +23950,10 @@ 9. Threads, Mutexes and Condit
-Thread (a virtual processor which shares object
-space with all other threads)
+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)
+Mutex (a mutual exclusion device, also known as a lock and binary semaphore)
Condition variable (a set of blocked threads)
@@ -23289,17 +23968,18 @@ 9. Threads, Mutexes and Condit
9.1. Threads
-
-
STklos procedure
+
@@ -23336,15 +24016,16 @@
9.1. Threads
-
-
STklos procedure
+
@@ -23357,15 +24038,16 @@
9.1. Threads
-
-
STklos procedure
+
@@ -23383,15 +24065,16 @@
9.1. Threads
-
-
STklos procedure
+
@@ -23400,15 +24083,16 @@
9.1. Threads
expired.
Thread-yield!
returns an unspecified value.
-
-
STklos procedure
+
@@ -23450,15 +24134,16 @@
9.1. Threads
-
-
STklos procedure
+
@@ -23468,17 +24153,18 @@
9.1. Threads
for timeout to be
#f
.
Thread-sleep!
returns an unspecified value.
-
-
STklos procedure
+
@@ -23500,15 +24186,16 @@
9.1. Threads
-
-
STklos procedure
+
@@ -23522,15 +24209,16 @@
9.1. Threads
-
-
STklos procedure
+
@@ -23543,15 +24231,16 @@
9.1. Threads
-
-
STklos procedure
+
@@ -23567,15 +24256,16 @@
9.1. Threads
Note that this procedure is not present in SRFI-18 .
-
-
STklos procedure
+
@@ -23583,15 +24273,16 @@
9.1. Threads
Returns the content of the `thread’s specific field.
-
-
STklos procedure
+
@@ -23611,16 +24302,17 @@
9.1. Threads
9.2. Mutexes
-
-
STklos procedure
+
@@ -23631,15 +24323,16 @@
9.2. Mutexes
The mutex’s specific field is set to an unspecified value.
-
-
STklos procedure
+
@@ -23647,15 +24340,16 @@
9.2. Mutexes
Returns #t
if obj is a mutex, otherwise returns #f
.
-
-
STklos procedure
+
@@ -23668,15 +24362,16 @@
9.2. Mutexes
-
-
STklos procedure
+
@@ -23684,15 +24379,16 @@
9.2. Mutexes
Returns the content of the `mutex’s specific field.
-
-
STklos procedure
+
@@ -23721,15 +24417,16 @@
9.2. Mutexes
-
-
STklos procedure
+
@@ -23770,17 +24467,18 @@
9.2. Mutexes
-
-
STklos procedure
+
@@ -23826,17 +24524,18 @@
9.2. Mutexes
-
-
STklos procedure
+
@@ -23854,15 +24553,16 @@
9.2. Mutexes
timeout
is reached, otherwise it returns
#t
.
-
-
STklos procedure
+
@@ -23876,16 +24576,17 @@
9.2. Mutexes
9.3. Condition Variables
-
-
STklos procedure
+
@@ -23896,15 +24597,16 @@
9.3. Condition Variables
field is set to an unspecified value.
-
-
STklos procedure
+
@@ -23912,15 +24614,16 @@
9.3. Condition Variables
Returns #t
if obj
is a condition variable, otherwise returns #f
.
-
-
STklos procedure
+
@@ -23928,15 +24631,16 @@
9.3. Condition Variables
Returns the name of the condition-variable
.
-
-
STklos procedure
+
@@ -23944,15 +24648,16 @@
9.3. Condition Variables
Returns the content of the `condition-variable’s specific field.
-
-
STklos procedure
+
@@ -23960,15 +24665,16 @@
9.3. Condition Variables
Stores obj
into the `condition-variable’s specific field.
-
-
STklos procedure
+
@@ -23978,15 +24684,16 @@
9.3. Condition Variables
an unspecified value.
-
-
STklos procedure
+
@@ -23998,15 +24705,16 @@
9.3. Condition Variables
9.4. Conditions
-
-
STklos procedure
+
@@ -24019,15 +24727,16 @@
9.4. Conditions
is reached and no timeout-val is supplied.
-
-
STklos procedure
+
@@ -24040,15 +24749,16 @@
9.4. Conditions
a mutex that was owned by a thread which terminated ,(see
mutex-lock!
).
-
-
STklos procedure
+
@@ -24062,15 +24772,16 @@
9.4. Conditions
thread-terminate!
.
-
-
STklos procedure
+
@@ -24084,15 +24795,16 @@
9.4. Conditions
the initial exception handler of that thread.
-
-
STklos procedure
+
@@ -24110,19 +24822,20 @@
10. STklos Customization
10.1. Parameter Objects
STklos environement can be customized using Parameter Objects. These
-parmaters are listed below.
+parameters are listed below.
-
-
STklos procedure
+
@@ -24189,16 +24902,17 @@
10.1. Parameter Objects
-
-
STklos procedure
+
@@ -24219,16 +24933,17 @@
10.1. Parameter Objects
-
-
STklos procedure
+
@@ -24270,16 +24985,17 @@
10.1. Parameter Objects
-
-
STklos procedure
+
@@ -24304,16 +25020,17 @@
10.1. Parameter Objects
-
-
STklos procedure
+
@@ -24336,16 +25053,17 @@
10.1. Parameter Objects
-
-
STklos procedure
+
@@ -24357,16 +25075,17 @@
10.1. Parameter Objects
until the file can be loaded.
-
-
STklos procedure
+
@@ -24377,16 +25096,17 @@
10.1. Parameter Objects
is set to
#f
, no message is printed.
-
-
STklos procedure
+
@@ -24400,15 +25120,16 @@
10.1. Parameter Objects
#t
.
-
-
STklos procedure
+
@@ -24418,18 +25139,190 @@
10.1. Parameter Objects
Note that the debugging level can also be set by the
--debug
option of the
stklos(1)
command.
+
+
+
10.2. Environment variables
-
+
The following variables can be used to customize STklos :
+
+
+
+
+STKLOS_LOAD_PATH : This is a colon-separated list
+of directories in which stklos looks for loading files. It is used by
+primitives such as load
or try-load
. See also the
+load-path
parameter.
+
+
+STKLOS-FRAME : This variable must contains an integer
+which indicates the number of frames printed on an error. Use
+the value 0 for an unlimited backtrace.
+
+
+STKLOS-CONFDIR : This variable can be used to
+designate the directory used by STklos to store its configuration or
+packages files. If not set, the default STklos configuration directory
+is by default ${XDG_CONFIG_HOME}/stklos
(or ~/.config/stklos
if the
+shell variable XDG_CONFIG_HOME
is unset).
+
+
+
+
+
+
10.3. REPL
+
+
By default, the STklos REPL try to find an installed
+editing line library to read input expressions. It tries to link with GNU readline
+[Readline] or BSD libedit [Libedit] libraries. Line editing offers editing
+capabilities while the user is entering the line (navigation in the line, in
+the history and function or file completion).
+
+
+
+
+
+
This procedure launches a new Read-Eval-Print-Loop. Calls to repl
can be
+embedded. The ports used for input/output as well as the error port can
+be passed when repl
is called. If not passed, they default to
+current-input-port
, current-output-port
and current-error-port
.
+
+
+
10.3.1. REPL commands
+
+
By default, STklos accepts some special commands. A command starts
+with a comma character, followed by the name of the command. The list
+of available commands is given below.
+
+
+
+
+,backtrace (or ,bt ): Show the stack when last error occurred
+
+
+,cd : Change current directory
+
+
+,pwd : Print working directory
+
+
+,ls : List directory content
+
+
+,quit (or ,q ): Exit STklos
+
+
+,shell (or ,! ): Run a shell command
+
+
+,time (or ,t ): Print the time used to run the next expression
+
+
+,describe (or ,d ): Describe an object
+
+
+,expand (or ,e ): Pretty print the macro expansion of a form
+
+
+,import (or ,i ): Import a library
+
+
+,require-feature (or ,r ): Require a feature
+
+
+,open (or ,o ): Open file or URL
+
+
+,manual (or ,m ): Search reference manual
+
+
+,apropos (or ,a ): Search symbols containing a given string
+
+
+,version (or ,v ): Show version
+
+
+,help (or ,? or *,h ): Show help on REPL command with
+parameter. With a parameter, display the help of this parameter
+
+
-
-
STklos procedure
+
+
+
+
Add a new command to the REPL. The names of the command are given in the
+first parameter as a list (or a symbol if there is only one name).
+The documentation of the command is given as a string as the second parameter.
+Finally, the function given as the third parameter is called when the new command
+is executed by the user. The code hereafter, permits to add a command to call an
+editor, with the commands ,editor
or ,ed
followed (eventually) by a file name.
+
+
+
+
( repl-add-command ' ( editor ed )
+ "Edit a file with $EDITOR (or emacs if unset)"
+ ( lambda ()
+ ( let (( cmd ( or ( getenv "EDITOR" ) "emacs" )))
+ ( system ( string-append cmd " " ( read-line ) " 2>/dev/null" )))))
+
+
+
+
+
+
+
+
+
+STklos has already a number of commands defined, but repl-add-command
can be
+useful to define you own command. A good place to add such a definition is in the
+stklosrc
file.
+
+
+
+
+
+
+
+
10.4. REPL parameters
+
+
The following parameter objects can be used to customize the REPL:
+
+
+
+
@@ -24503,16 +25396,17 @@
10.1. Parameter Objects
-
-
STklos procedure
+
@@ -24536,34 +25430,6 @@
10.1. Parameter Objects
-
-
10.2. Environment variables
-
-
The following variables can be used to customize STklos :
-
-
-
-
-STKLOS_LOAD_PATH : This is a colon-separated list
-of directories in which stklos looks for loading files. It is used by
-primitives such as load
or try-load
. See also the
-load-path
parameter.
-
-
-STKLOS-FRAME : This variable must contains an integer
-which indicates the number of frames printed on an error. Use
-the value 0 for an unlimited backtrace.
-
-
-STKLOS-CONFDIR : This variable can be used to
-designate the directory used by STklos to store its configuration or
-packages files. If not set, the default STklos configuration directory
-is by default ${XDG_CONFIG_HOME}/stklos
(or ~/.config/stklos
if the
-shell variable XDG_CONFIG_HOME
is unset).
-
-
-
-
@@ -24690,15 +25556,16 @@
11.1. External functions
-
-
STklos syntax
+
@@ -24911,15 +25778,16 @@
11.2. C pointers
-
-
STklos procedure
+
@@ -24928,15 +25796,16 @@
11.2. C pointers
a pointer to a C object), and
#f
otherwise.
-
-
STklos procedure
+
@@ -24945,17 +25814,18 @@
11.2. C pointers
Returnd
#f
otherwise.
-
-
STklos procedure
+
@@ -24969,17 +25839,18 @@
11.2. C pointers
fatal errors.
-
-
STklos procedure
+
@@ -24996,15 +25867,16 @@
11.2. C pointers
tag
(which can be of any type).
-
-
STklos procedure
+
@@ -25026,15 +25898,16 @@
11.2. C pointers
-
-
STklos procedure
+
@@ -25047,15 +25920,16 @@
11.2. C pointers
to be freed.
-
-
STklos procedure
+
@@ -25594,6 +26468,7 @@
srfi-4 —
SRFI-4 is fully supported and is extended to provide the
additional c64vector and c128vector types of SRFI-160 (Homogeneous numeric vector libraries ).
+
@@ -25601,18 +26476,18 @@ srfi-4 —
-
-
STklos procedure
+
@@ -25676,16 +26551,17 @@
srfi-19 — Time
"2000 Nov 12 02:30:10 GMT-1".
-
-
STklos procedure
+
@@ -25707,23 +26583,24 @@
srfi-19 — Time
-
-
R5 RS procedure
+
@@ -25755,15 +26632,16 @@
srfi-19 — Time
An attempt to compare times of different type will raise an error.
-
-
STklos procedure
+
@@ -25844,15 +26722,16 @@
srfi-25 — Multi-dime
functions, not present in the SRFI, are documented here.
-
-
STklos procedure
+
@@ -25864,15 +26743,16 @@
srfi-25 — Multi-dime
integer r
.
-
-
STklos procedure
+
@@ -25881,15 +26761,16 @@
srfi-25 — Multi-dime
arrays, and #f
otherwise.
-
-
STklos procedure
+
@@ -25947,15 +26828,16 @@
srfi-25 — Multi-dime
-
-
STklos procedure
+
@@ -25981,15 +26863,16 @@
srfi-25 — Multi-dime
-
-
STklos procedure
+
@@ -26005,15 +26888,16 @@
srfi-25 — Multi-dime
-
-
STklos procedure
+
@@ -26029,16 +26913,17 @@
srfi-25 — Multi-dime
-
-
STklos procedure
+
@@ -26054,15 +26939,16 @@
srfi-25 — Multi-dime
-
-
STklos procedure
+
@@ -26073,15 +26959,16 @@
srfi-25 — Multi-dime
array, sharing the elements in the same way.
-
-
STklos procedure
+
@@ -26089,15 +26976,16 @@
srfi-25 — Multi-dime
Returns the number of elements in array
.
-
-
STklos procedure
+
@@ -26105,15 +26993,16 @@
srfi-25 — Multi-dime
Returns the shape of array
.
-
-
STklos procedure
+
@@ -26123,15 +27012,16 @@
srfi-25 — Multi-dime
This is not recursive, and will not flatten the array.
-
-
STklos procedure
+
@@ -26142,15 +27032,16 @@
srfi-25 — Multi-dime
This is not recursive, and will not flatten the array.
-
-
STklos procedure
+
@@ -26158,15 +27049,16 @@
srfi-25 — Multi-dime
Returns the length of dimension dim
in array array
.
-
-
STklos procedure
+
@@ -26184,15 +27076,16 @@
srfi-25 — Multi-dime
(or arr0
's shape, if shape
was not specified).
-
-
STklos procedure
+
@@ -26206,15 +27099,16 @@
srfi-25 — Multi-dime
array
, and only that section will be mapped.
-
-
STklos procedure
+
@@ -26239,15 +27133,16 @@
srfi-25 — Multi-dime
-
-
STklos procedure
+
@@ -26261,15 +27156,16 @@
srfi-25 — Multi-dime
a specific object will be collected.
-
-
STklos procedure
+
@@ -26279,15 +27175,16 @@
srfi-25 — Multi-dime
argument array
did.
-
-
STklos procedure
+
@@ -26311,16 +27208,17 @@
srfi-25 — Multi-dime
on index-object
.
-
-
STklos procedure
+
@@ -26335,15 +27233,16 @@
srfi-25 — Multi-dime
if it is #f
, then an index vector will be created internally.
-
-
STklos procedure
+
@@ -26360,15 +27259,16 @@
srfi-25 — Multi-dime
-
-
STklos procedure
+
@@ -26517,15 +27417,16 @@
srfi-116 — Immutable
STklos implements the arrays of SRFI-116 .
-
-
STklos procedure
+
@@ -26535,15 +27436,16 @@
srfi-116 — Immutable
from every existing object.
-
-
STklos procedure
+
@@ -26560,15 +27462,16 @@
srfi-116 — Immutable
Being an ilist, its CAR, CDR and all sublists are immutable.
-
-
STklos procedure
+
@@ -26588,15 +27491,16 @@
srfi-116 — Immutable
The name stands for "eXchanged Immutable PAIR."
-
-
STklos procedure
+
@@ -26612,15 +27516,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -26635,15 +27540,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -26659,15 +27565,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -26675,15 +27582,16 @@
srfi-116 — Immutable
Copies the spine of the argument, including the ilist tail.
-
-
STklos procedure
+
@@ -26705,17 +27613,18 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -26733,15 +27642,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -26750,17 +27660,18 @@
srfi-116 — Immutable
a ()-terminated ilist.
-
-
STklos procedure
+
@@ -26777,15 +27688,16 @@
srfi-116 — Immutable
be dotted ilists of length 0.
-
-
STklos procedure
+
@@ -26801,15 +27713,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -26822,15 +27735,16 @@
srfi-116 — Immutable
all ilists, both proper and dotted.
-
-
STklos procedure
+
@@ -26842,15 +27756,16 @@
srfi-116 — Immutable
procedures that are not defined on dotted ilists.
-
-
STklos procedure
+
@@ -26901,17 +27816,18 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -26921,7 +27837,8 @@
srfi-116 — Immutable
List-immutable+!
returns the list, while list-immutable!
returns #void
.
-
+
+
@@ -26932,22 +27849,22 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -26960,15 +27877,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -26977,19 +27895,20 @@
srfi-116 — Immutable
the icar and the icdrif ip
.
-
-
STklos procedure
+
@@ -27030,17 +27949,18 @@
srfi-116 — Immutable
the returned value shares a common tail with x
.
-
-
STklos procedure
+
@@ -27082,15 +28002,16 @@
srfi-116 — Immutable
with dilist
.
-
-
STklos procedure
+
@@ -27105,17 +28026,18 @@
srfi-116 — Immutable
-
-
R5 RS procedure
+
@@ -27131,15 +28053,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27152,15 +28075,16 @@
srfi-116 — Immutable
icdr
applied n times to the ilist produces the empty list.
-
-
STklos procedure
+
@@ -27189,15 +28113,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27223,15 +28148,16 @@
srfi-116 — Immutable
value at all.
-
-
STklos procedure
+
@@ -27246,15 +28172,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27272,15 +28199,16 @@
srfi-116 — Immutable
storage reclamation.)
-
-
STklos procedure
+
@@ -27303,23 +28231,24 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27341,15 +28270,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27369,15 +28299,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27406,15 +28337,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27435,15 +28367,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27503,15 +28436,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27601,15 +28535,16 @@
srfi-116 — Immutable
tail-gen procedure is supplied, it is called an "apomorphism."
-
-
STklos procedure
+
@@ -27634,15 +28569,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27689,15 +28625,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27741,15 +28678,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27837,15 +28775,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27869,15 +28808,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27904,15 +28844,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27951,15 +28892,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -27978,15 +28920,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28004,15 +28947,16 @@
srfi-116 — Immutable
not specified.
-
-
R5 RS procedure
+
@@ -28023,15 +28967,16 @@
srfi-116 — Immutable
useful values.
-
-
STklos procedure
+
@@ -28049,15 +28994,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28078,15 +29024,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28112,19 +29059,20 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28172,15 +29120,16 @@
srfi-116 — Immutable
-
-
R5 RS procedure
+
@@ -28210,15 +29159,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28249,15 +29199,16 @@
srfi-116 — Immutable
element that doesn’t satisfy the predicate.
-
-
STklos procedure
+
@@ -28297,15 +29248,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28336,15 +29288,16 @@
srfi-116 — Immutable
general value.
-
-
R5 RS procedure
+
@@ -28375,15 +29328,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28397,15 +29351,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28419,17 +29374,18 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28462,15 +29418,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28504,15 +29461,16 @@
srfi-116 — Immutable
numbers greater than five from an ilist with (idelete 5 ilist <)
.
-
-
STklos procedure
+
@@ -28526,15 +29484,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28570,19 +29529,20 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28632,15 +29592,16 @@
srfi-116 — Immutable
-
-
STklos procedure
+
@@ -28662,17 +29623,18 @@
srfi-116 — Immutable
than five with (ialist-delete 5 ialist <)
-
-
STklos procedure
+
@@ -28685,17 +29647,18 @@
srfi-116 — Immutable
the icar of ipair in the icar field.
-
-
STklos procedure
+
@@ -28710,17 +29673,18 @@
srfi-116 — Immutable
It is an error to apply list→ilist to a circular list.
-
-
STklos procedure
+
@@ -28730,17 +29694,18 @@
srfi-116 — Immutable
fields as the argument.
-
-
STklos procedure
+
@@ -28758,17 +29723,18 @@
srfi-116 — Immutable
pairs.
-
-
STklos procedure
+
@@ -28780,15 +29746,16 @@
srfi-116 — Immutable
If the argument is neither a pair nor an ipair, it is returned.
-
-
STklos procedure
+
@@ -28849,6 +29816,17 @@
srfi-216 — SICP
+
srfi-230 — Atomic Operations
+
+
+
SRFI-238 is fully supported if STklos was compiled
+with Posix threads. If STklos was compiled without thread support,
+the module (srfi 230)
is defined, but it exports nothing.
+
+
+
srfi-238 — Codesets
@@ -28858,15 +29836,16 @@
srfi-238 — Codesets
adds the functions
codeset-list
and
make-codeset
.
-
-
STklos procedure
+
@@ -28879,15 +29858,16 @@
srfi-238 — Codesets
-
-
STklos procedure
+
@@ -28940,6 +29920,9 @@
Bibliography
[GTK] The GTK+ Toolkit Home Page
+ [Libedit] Editline library (libedit)
+
+
[PCRE] Philip Hazel — PCRE (Perl Compatible Regular Expressions)
Home page.
@@ -28957,6 +29940,9 @@
Bibliography
[R7RS] Alex S. Shinn, John Cowan and Arthur A. Gleckler — The Revised7 Report on the Algorithmic Language Scheme — R7RS small — July, 2013.
+ [Readline] The GNU readline library.
+
+
[SLIB] Aubrey Jaffer — The SLIB Portable Scheme Library Home Page
@@ -29147,15 +30133,16 @@ R7 RS Large Libraries
bytevector functions.
-
-
STklos procedure
+
@@ -29176,15 +30163,16 @@
R7 RS Large Libraries
-
-
STklos procedure
+
@@ -29208,15 +30196,16 @@
R7 RS Large Libraries
-
-
STklos procedure
+
@@ -29227,15 +30216,16 @@
R7 RS Large Libraries
vector-fill!
.
-
-
STklos procedure
+
@@ -29245,21 +30235,22 @@
R7 RS Large Libraries
indices. It returns false otherwise.
-
-
STklos procedure
+
@@ -29324,15 +30315,16 @@
R7 RS Large Libraries
-
-
R5 RS procedure
+
@@ -29347,15 +30339,16 @@
R7 RS Large Libraries
to be anything other than
little
or
big
.
-
-
STklos procedure
+
@@ -29406,15 +30399,16 @@
(stklos itrie) Library
The symbols exported by (stklos itrie)
are described below:
-
-
STklos procedure
+
@@ -29437,17 +30431,18 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -29460,17 +30455,18 @@
(stklos itrie) Library
number of arguments is not even.
-
-
STklos procedure
+
@@ -29481,15 +30477,16 @@
(stklos itrie) Library
It is an error if any of the keys is not an integer.
-
-
STklos procedure
+
@@ -29509,15 +30506,16 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -29525,16 +30523,17 @@
(stklos itrie) Library
Returns true if map
contains an association for element
, and false otherwise.
-
-
STklos procedure
+
@@ -29544,15 +30543,16 @@
(stklos itrie) Library
If
obj
is not an fxmapping object, an error is sginaled.
-
-
STklos procedure
+
@@ -29562,15 +30562,16 @@
(stklos itrie) Library
proportional to this value.
-
-
STklos procedure
+
@@ -29584,15 +30585,16 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -29600,15 +30602,16 @@
(stklos itrie) Library
Returns #t
is obj
is a mutable fxmapping and #f
otherwise.
-
-
STklos procedure
+
@@ -29622,15 +30625,16 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -29638,15 +30642,16 @@
(stklos itrie) Library
Returns the number of key/value pairs in an fxmap.
-
-
STklos procedure
+
@@ -29663,21 +30668,22 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -29712,16 +30718,17 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -29729,23 +30736,24 @@
(stklos itrie) Library
Returns #t
is obj
is an fxmapping object and #f
otherwise.
-
-
STklos procedure
+
@@ -29763,15 +30771,16 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -29785,17 +30794,18 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -29814,15 +30824,16 @@
(stklos itrie) Library
iset-adjoin
. In STklos, it is an alias to
iset-adjoin
.
-
-
STklos procedure
+
@@ -29838,21 +30849,22 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -29870,15 +30882,16 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -29886,15 +30899,16 @@
(stklos itrie) Library
Returns true if set
contains element
, and false otherwise.
-
-
STklos procedure
+
@@ -29902,15 +30916,16 @@
(stklos itrie) Library
Returns a newly allocated iset containing the elements of set
.
-
-
STklos procedure
+
@@ -29924,21 +30939,22 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -29966,21 +30982,22 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30006,15 +31023,16 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30028,16 +31046,17 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30047,15 +31066,16 @@
(stklos itrie) Library
If
obj
is not an iset object, an error is sginaled.
-
-
STklos procedure
+
@@ -30071,17 +31091,18 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30099,15 +31120,16 @@
(stklos itrie) Library
iset-filter!
is allowed to modify set
, but in STklos it does not.
-
-
STklos procedure
+
@@ -30122,17 +31144,18 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30151,15 +31174,16 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30177,15 +31201,16 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30195,15 +31220,16 @@
(stklos itrie) Library
proportional to this value.
-
-
STklos procedure
+
@@ -30223,17 +31249,18 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30248,15 +31275,16 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30265,15 +31293,16 @@
(stklos itrie) Library
of
set
, then
default
is returned.
-
-
STklos procedure
+
@@ -30281,17 +31310,18 @@
(stklos itrie) Library
Returns #t
is obj
is a mutable iset and #f
otherwise.
-
-
STklos procedure
+
@@ -30310,17 +31340,18 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30338,17 +31369,18 @@
(stklos itrie) Library
Iset-remove!
is allowed to modify set
, but in STklos it does not.
-
-
STklos procedure
+
@@ -30388,15 +31420,16 @@
(stklos itrie) Library
allocating a new iset. In STklos, it does not.
-
-
STklos procedure
+
@@ -30404,15 +31437,16 @@
(stklos itrie) Library
Returns the number of fixnums in set
.
-
-
STklos procedure
+
@@ -30434,7 +31468,8 @@
(stklos itrie) Library
-
+
+
@@ -30443,20 +31478,20 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30484,16 +31519,17 @@
(stklos itrie) Library
versions.
-
-
STklos procedure
+
@@ -30501,23 +31537,24 @@
(stklos itrie) Library
Returns #t
is obj
is an iset and #f
otherwise.
-
-
STklos procedure
+
@@ -30535,16 +31572,17 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30567,15 +31605,16 @@
(stklos itrie) Library
-
-
STklos procedure
+
@@ -30634,16 +31673,17 @@
A.2. STklos compiler
compile-file
procedure.
-
-
STklos procedure
+
@@ -30667,16 +31707,17 @@
A.2.1. Compiler flags
STklos compiler behaviour can be customized by several parameters. Those parameters are described below.
-
-
STklos procedure
+
@@ -30685,16 +31726,17 @@
A.2.1. Compiler flags
displayed or not. It defaults to
#t
.
-
-
STklos procedure
+
@@ -30706,16 +31748,17 @@
A.2.1. Compiler flags
`#t
when
STklos is launched in debug mode).
-
-
STklos procedure
+
@@ -30725,16 +31768,17 @@
A.2.1. Compiler flags
of the produced file. This parameter defaults to
#f
.
-
-
STklos procedure
+
@@ -30783,16 +31827,17 @@
A.2.1. Compiler flags
-
-
STklos procedure
+
@@ -30823,16 +31868,17 @@
A.2.1. Compiler flags
-
-
STklos procedure
+
@@ -30856,16 +31902,17 @@
A.2.1. Compiler flags
-
-
STklos procedure
+
@@ -31446,7 +32493,7 @@
B.13. ADDENDUM: Ho
diff --git a/doc/HTML/vm.html b/doc/HTML/vm.html
index 919df9e0c..bc171cd20 100644
--- a/doc/HTML/vm.html
+++ b/doc/HTML/vm.html
@@ -677,7 +677,11 @@
.tocify-focus > a {
color: #7a2518;
-}
+ }
+
+ /* Customize default CSS */
+.sidebarblock { margin-top: -1em; }
+
-
-
-
-
-
-
diff --git a/doc/refman/biblio.adoc b/doc/refman/biblio.adoc
index 0245035e7..6aabdb2b9 100644
--- a/doc/refman/biblio.adoc
+++ b/doc/refman/biblio.adoc
@@ -1,6 +1,6 @@
// SPDX-License-Identifier: GFDL-1.3-or-later
//
-// Copyright © 2000-2022 Erick Gallesio
+// Copyright © 2000-2023 Erick Gallesio
//
// Author: Erick Gallesio [eg@unice.fr]
// Creation date: 26-Nov-2000 18:19 (eg)
@@ -27,6 +27,8 @@
* [[[GTK]]] http://gtk.org/[*The GTK+ Toolkit Home Page*]
+* [[[Libedit]]] https://www.thrysoee.dk/editline[Editline library (libedit)]
+
* [[[PCRE]]] Philip Hazel -- http://pcre.org/[*PCRE (Perl Compatible Regular Expressions)*]
Home page.
@@ -44,6 +46,8 @@ with Intelligent Backtrack* -- Workshop in Static Analysis, Bigre, (81--82), Bor
https://small.r7rs.org/attachment/r7rs.pdf[*The Revised7 Report on the Algorithmic Language Scheme -- R7RS small*]
-- July, 2013.
+* [[[Readline]]] The GNU https://tiswww.case.edu/php/chet/readline/rltop.html[readline] library.
+
* [[[SLIB]]] Aubrey Jaffer -- https://people.csail.mit.edu/jaffer/SLIB[*The SLIB Portable Scheme Library Home Page*]
* [[[SOS]]] Chris Hanson --
diff --git a/doc/refman/custom.adoc b/doc/refman/custom.adoc
index a4def3852..692914cec 100644
--- a/doc/refman/custom.adoc
+++ b/doc/refman/custom.adoc
@@ -11,7 +11,7 @@
=== Parameter Objects
{{stklos}} environement can be customized using Parameter Objects. These
-parmaters are listed below.
+parameters are listed below.
{{insertdoc 'real-precision}}
[#srfi169]
@@ -26,11 +26,6 @@ parmaters are listed below.
{{insertdoc 'load-verbose}}
{{insertdoc 'thread-handler-error-show}}
{{insertdoc 'stklos-debug-level}}
-{{insertdoc 'repl-theme}}
-{{insertdoc 'repl-show-startup-message}}
-
-
-
=== Environment variables
@@ -51,3 +46,48 @@ The following variables can be used to customize {{stklos}}:
packages files. If not set, the default {{stklos}} configuration directory
is by default `${XDG_CONFIG_HOME}/stklos` (or `~/.config/stklos` if the
shell variable `XDG_CONFIG_HOME` is unset).
+
+=== REPL
+
+By default, the (((REPL))){{stklos}} REPL try to find an installed
+_editing line library_ to read input expressions. It tries to link with GNU readline
+<> or BSD libedit <> libraries. Line editing offers editing
+capabilities while the user is entering the line (navigation in the line, in
+the history and function or file completion).
+
+{{insertdoc 'repl}}
+
+
+==== REPL commands
+
+By default, {{stklos}} accepts some special commands. A command starts
+with a comma character, followed by the name of the command. The list
+of available commands is given below.
+
+- **,backtrace** (or **,bt**): Show the stack when last error occurred
+- **,cd**: Change current directory
+- **,pwd**: Print working directory
+- **,ls**: List directory content
+- **,quit** (or **,q**): Exit STklos
+- **,shell** (or **,!**): Run a shell command
+- **,time** (or **,t** ): Print the time used to run the next expression
+- **,describe** (or **,d**): Describe an object
+- **,expand** (or **,e**): Pretty print the macro expansion of a form
+- **,import** (or **,i**): Import a library
+- **,require-feature** (or **,r**): Require a feature
+- **,open** (or **,o**): Open file or URL
+- **,manual** (or **,m**): Search reference manual
+- **,apropos** (or **,a**): Search symbols containing a given string
+- **,version** (or **,v**): Show version
+- **,help** (or **,?** or **,h*): Show help on REPL command with
+ parameter. With a parameter, display the help of this parameter
+
+{{insertdoc 'repl-add-command}}
+
+=== REPL parameters
+
+The following parameter objects can be used to customize the REPL:
+
+{{insertdoc 'repl-theme}}
+{{insertdoc 'repl-show-startup-message}}
+
diff --git a/doc/refman/object.adoc b/doc/refman/object.adoc
index 087cc2caa..88dbfec75 100644
--- a/doc/refman/object.adoc
+++ b/doc/refman/object.adoc
@@ -575,7 +575,7 @@ not needed.
((("next-method")))
When a generic function is called, the list of applicable
methods is built. As mentioned before, the most specific method
-of this list is applied (see <<_generic_function>>).
+of this list is applied (see <<_generic_functions>>).
This method may call, if needed, the next method in the list of
applicable methods. This is done by using the special form
diff --git a/doc/refman/adoc-lib.stk b/doc/refman/refman-lib.stk
similarity index 87%
rename from doc/refman/adoc-lib.stk
rename to doc/refman/refman-lib.stk
index 99a0fe573..bea59149c 100644
--- a/doc/refman/adoc-lib.stk
+++ b/doc/refman/refman-lib.stk
@@ -2,7 +2,7 @@
;;;;
;;;; adoc-lib.stk -- Library for Stklos documentation
;;;;
-;;;; Copyright © 2022 Erick Gallesio - I3S-CNRS/Polytech Nice-Sophia
+;;;; Copyright © 2022-2023 Erick Gallesio
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
@@ -26,21 +26,6 @@
(import (stklos preproc))
-
-(define *stderr* (current-error-port))
-(define *verbose* (getenv "DEBUG"))
-
-(define (stklos) "*_STklos_*")
-(define (stk) "*_STk_*")
-(define (rfour) "R^4^RS")
-(define (rfive) "R^5^RS")
-(define (rsix) "R^6^RS")
-(define (rseven) "R^7^RS")
-(define (sharp) "#")
-(define (true) "`#t`")
-(define (false) "`#f`")
-
-
;;;
;;; SRFIs
;;;
@@ -85,7 +70,7 @@
;======================================================================
;
-; rewrite-for-skribe
+; rewrite-for-adoc
;
;======================================================================
(define var-rgxp (string->regexp "\\|([^|]+)\\|"))
@@ -133,8 +118,6 @@
def)
-
-
;;;
;;; Insertdoc
;;;
@@ -164,19 +147,34 @@
((extended-syntax) "_STklos_ syntax")
((extended) "_STklos_ procedure")))
+ (define (produce-IDs)
+ (if (equal? (document-value 'doc-fmt #f) "html")
+ ;; We are producing HTM, let's go.
+ (string-append
+ "+++"
+ (apply string-append
+ (map (lambda (x) (format " " x)) (cons name similar)))
+ "+++\n")
+ ;; We are not producing HTML, do not build custom IDs
+ ""))
+
(string-append
+ ;; Put custom ID for all the functions defined in this entry
+ (produce-IDs)
;; Put marks for all the functions defined in this entry
(apply string-append
(map (lambda (x) (format "(((~A)))\n" x)) (cons name similar)))
;; Display type
+ "[.rmargin]\n"
"[.text-right]\n"
- (format "[.rmargin.small]#~a#\n" (show-type type))
+ (format "[.rmargin.small.silver]#~a#\n" (show-type type))
;; Make a box
"****\n"
- ;; Display the synopsys
+ ;; Display the synopsis
"[.small]\n"
(apply string-append
- (map (lambda (x) (format "*`~a`* +\n" x)) synopsis)) ; "*+~a+* +\n"
+ (map (lambda (x) (format "`**~a **` +\n" x)) ; Let a space before closing "**"
+ synopsis))
"****\n"
;; Display the description text
(process-string (rewrite-for-adoc txt))
@@ -223,20 +221,6 @@
;;;
-;;; Helpers
-;;;
-(define (empty-line n)
- (if (zero? n)
- ""
- (string-append (empty-line (- n 1))
- "+++ +++ +\n"))) ;; Quite hacky, but seems to work
-
-(define (chapter title)
- (string-append "== " title "\n\n")) ;; empty lines are now in config files
-
-
-
-;;;
-;;; Init library
+;;; Initialize library
;;;
(read-database "../DOCDB")
diff --git a/doc/refman/srfi.adoc b/doc/refman/srfi.adoc
index 1911d6df0..a698e34a0 100644
--- a/doc/refman/srfi.adoc
+++ b/doc/refman/srfi.adoc
@@ -455,12 +455,20 @@ underscores in numbers.
`stream-null?` which are incompatible with the ones defined in the `(stream primitive)` library used by
{{quick-link-srfi 41}} or {{quick-link-srfi 221}}. Prefix the imported symbols of this SRFI, if you plan to
use it with one of the previous libraries.
+
+// **** SRFI-230
+{{srfi-subsection 230}}
+
+{{quick-link-srfi 238}} is fully supported if {{stklos}} was compiled
+with Posix threads. If {{stklos}} was compiled without thread support,
+the module `(srfi 230)` is defined, but it exports nothing.
+
// **** SRFI-238
{{srfi-subsection 238}}
{{quick-link-srfi 238}} is fully supported. Furthermore, {{stklos}}
-adds the functions `codeset-list` and `make-codeset`.
+adds the functions `codeset-list` and `make-codeset`.
{{insertdoc 'codeset-list}}
{{insertdoc 'make-codeset}}
diff --git a/doc/refman/stdproc.adoc b/doc/refman/stdproc.adoc
index ed1a0de67..3d3976b19 100644
--- a/doc/refman/stdproc.adoc
+++ b/doc/refman/stdproc.adoc
@@ -681,6 +681,7 @@ primivitives to acess environment variables.
{{insertdoc 'get-environment-variables}}
{{insertdoc 'build-path-from-shell-variable}}
+{{insertdoc 'install-path}}
==== Time
{{insertdoc 'current-second}}
@@ -938,6 +939,7 @@ you plan to port your program on another system.
See SRFI document for more information.
{{insertdoc 'make-parameter}}
+{{insertdoc 'define-parameter}}
{{insertdoc 'parameterize}}
{{insertdoc 'parameter?}}
@@ -958,7 +960,7 @@ See SRFI document for more information.
{{insertdoc 'error-object-location}}
{{insertdoc 'require-extension}}
{{insertdoc 'require-feature}}
-{{insertdoc 'repl}}
+
[#assume]
{{insertdoc 'assume}}
((("SRFI-176")))
@@ -966,6 +968,10 @@ See SRFI document for more information.
{{insertdoc 'apropos}}
{{insertdoc 'help}}
{{insertdoc 'describe}}
+{{insertdoc 'default-browser}}
+{{insertdoc 'open-in-browser}}
+{{insertdoc 'manual}}
+
{{insertdoc 'trace}}
{{insertdoc 'untrace}}
diff --git a/doc/refman/stklos.adoc b/doc/refman/stklos.adoc
index e3df0185b..522897843 100644
--- a/doc/refman/stklos.adoc
+++ b/doc/refman/stklos.adoc
@@ -21,8 +21,9 @@
:docinfodir: ../lib/theme
:docinfo: shared
-
-{{load "adoc-lib.stk"}}
+// Load the general adoc library and the refman specific one
+{{load "../lib/adoc-lib.stk"}}
+{{load "refman-lib.stk"}}
[preface]
== Preface
@@ -52,8 +53,8 @@ following URL: https://www.gnu.org/licenses/gpl-3.0.html
* The manual you’re now reading is published under the terms of the
_GNU Free Documentation License or later_ (see <>).
-
-{{If (equal? doc-fmt "pdf")}}{{empty-line 14}} {{End}}
+{{empty-line 1}}
+{{If (equal? doc-fmt "pdf")}}{{empty-line 13}}{{End}}
****
Copyright © 1999-{{date-year (current-date)}} Erick Gallesio
@@ -75,7 +76,9 @@ Free Documentation License">>.
{{Include* "match.adoc"}}
{{Include* "cond.adoc"}}
{{Include* "object.adoc"}}
-{{Include* "threads.adoc"}}
+{{If (not (eq? (%thread-system) 'none))}}
+ {{Include* "threads.adoc"}}
+{{End}}
{{Include* "custom.adoc"}}
{{Include* "ffi.adoc"}}
{{Include* "slib.adoc"}}
diff --git a/doc/refman/threads.adoc b/doc/refman/threads.adoc
index fb8703b0e..7289bace8 100644
--- a/doc/refman/threads.adoc
+++ b/doc/refman/threads.adoc
@@ -12,10 +12,8 @@
((("condition variable")))
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)
+* 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)
diff --git a/doc/stklos.1.in b/doc/stklos.1.in
index c6554004a..13a92cbfe 100644
--- a/doc/stklos.1.in
+++ b/doc/stklos.1.in
@@ -114,8 +114,8 @@ Boolean flags must begin by a '+' or a '-' character to indicate if the flag is
or unset. Valued flags, must be followed by a '=' and the value given to the flag.
Flags are separated by the ',' character. For instance, the following
list \fI-F=+line-info,-time-display,unroll-iterations=5\fR sets the
-\fIline-info\fR option, unsets the \fItime-display\fR option and initialzes the
-\fIunroll-iteration\R to 5. The following flags can be used with
+\fIline-info\fR option, unsets the \fItime-display\fR option and initializes the
+\fIunroll-iteration\fR to 5. The following flags can be used with
this option:
.IP "" 10
- \fIline-info\fR insert line numbers in the generated file. Setting this flag
diff --git a/doc/vm/vm.adoc b/doc/vm/vm.adoc
index 523eca4b7..24aaf0cf3 100644
--- a/doc/vm/vm.adoc
+++ b/doc/vm/vm.adoc
@@ -1,7 +1,5 @@
// SPDX-License-Identifier: GFDL-1.3-or-later
//
-// Copyright © 2000-2023 Erick Gallesio
-//
// Author: Jeronimo Pellegrini
// Creation date: 4-Feb-2022 09:48
@@ -506,71 +504,108 @@ Constants:
0: my-cool-global-variable
....
-=== UGLOBAL_{REF,SET} and the checked global table
+=== UGLOBAL_{REF,SET} and the checked global variables
+
+Internally, the global variables values of a program are stored in a unique
+array called `STk_global_store`.
The instructions `GLOBAL_REF` and `GLOBAL_SET` do the following:
-1. Acquire the mutex
-2. Fetch the index of the global variable
-3. Lookup the variable in the current environment (that is, consult a hash table
- in amodule)
-4. Verify if the variable is mutable or not
-5. Finally, do the real get or set operation
-6. Release the lock
+1. Fetch the name of the global variable
+2. Lookup the variable in the current environment (that is, consult a hash table
+ in a module)
+3. Verify if the variable is mutable or not
+4. Finally, do the real get or set operation in `STk_global_store`.
-Steps 1-4 are quite expensive, and shouldn't need to be done every time the
-variable is accessed. Thus, the STklos VM keeps a table with *checked globals*.
-The first time a variable is referenced, the VM goes through all those steps,
-but before releasing the lock there is another step:
+Steps 1-3 are quite expensive, and shouldn't need to be done every time the
+variable is accessed. Thus, the STklos VM patches the original code when
+we are sure that the variable used is properly defined. Hence, he first time a
+variable is referenced, the VM goes through all those steps, adds a final step:
-5'. **Patch the code**, changing the `GLOBAL_REF` or `GLOBAL_SET` insrtuction
- into a `UGLOBAL_REF` or `UGLOBAL_SET`.
+[start=5]
+. **Patch the code**, that is, changing the `GLOBAL_REF` or `GLOBAL_SET` instruction
+ into a `UGLOBAL_REF` or `UGLOBAL_SET` ('U' prefix here is for already **U**sed vrariable)
-For example, in `GLOBAL_SET` this step is performed by the following two lines:
+For example, in `GLOBAL_SET`, this step is performed by the following two lines:
[source,c]
----
/* patch the code for optimize next accesses */
- vm->pc[-1] = add_global(CDR(ref));
+ vm->pc[-1] = global_var_index(ref); // ref: result of the search in the hash table
vm->pc[-2] = UGLOBAL_SET;
----
See that what is being changed are the two previous bytecode elements,
-`pc[-1]` and `pc[-2]`.
+`pc[-1]` and `pc[-2]`. Note that the value returned by `global_var_index` is
+the index in `STk_global_store` where the used variable is stored.
-So the code
+So the code:
[source,scheme]
----
-(set! a 2)
+(define (test) (set! a 2))
----
-would perhaps be translated into
+is translated in
----
-000: SMALL-INT 2
-002: GLOBAL-SET 5
+000: CREATE-CLOSURE 6 0 ;; ==> 008
+003: SMALL-INT 2
+005: GLOBAL-SET 0
+007: RETURN
+008: DEFINE-SYMBOL 1
+010:
+
+Constants:
+0: a
+1: test
----
-where `5` is the index of the variable `a` (as a global).
+The second and third lines are used for doing this assignment. We can see that
+the parameter of the `GLOBAL_SET` instruction is the name of the variable to
+be set.
-Then after the first time the `GLOBAL_SET` instruction is performed, the
-code will **patch itself** and change into
+
+Then, after the first time the `GLOBAL_SET` instruction is performed, the
+code will **patch itself** and changed into
----
000: SMALL-INT 2
002: UGLOBAL-SET n
----
-where `n` is the index of this global variable **in a local table**.
+where `n` is the index of this global variable in the `STk_global_store`
+array.
The instruction `GLOBAL_SET` takes two integers to be represented, so
when `pc[-1]` and `pc[-2]` are changed, what is being changed is the
-previous argument (`5` -> `n`) and the previous instruction
+previous argument (`0` -> `n`) and the previous instruction
(`GLOBAL_SET` -> `UGLOBAL_SET`).
-*And*, of course, the `n`-th element of the table contains the address
-of the variable to be set. This is made clear in the code of `UGLOBAL_SET`:
+*And*, of course, the `n`-th element of the table contains the value of the
+variable to be set. We can see this by disassembling the `test` function defined
+before:
+
+----
+stklos> (disassemble test)
+000: SMALL-INT 2
+002: GLOBAL-SET 0
+004: RETURN
+----
+
+Once `test` has been called at least one time, its code is:
+
+----
+stklos> (disassemble test)
+000: SMALL-INT 2
+002: UGLOBAL-SET 2971
+004: RETURN
+----
+
+Here, `2971` is the index of the global variable `a` in the array of global
+variables.
+
+Let's see now the code of `UGLOBAL_SET`:
[source,c]
----
@@ -582,19 +617,21 @@ CASE(UGLOBAL_SET) { /* Never produced by compiler */
}
----
-The checked globals table is defined earlier in `vm.c`:
+The `fetch_global` macro is defined earlier in `vm.c`:
[source,c]
----
-static SCM** checked_globals;
-...
-#define fetch_global() (*(checked_globals[(unsigned) fetch_next()]))
+#define fetch_next() (*(vm->pc)++)
+#define fetch_global() (STk_global_store[(unsigned) fetch_next()])
----
-and the function `add_global(SCM ref)` will add a global to the table.
+The `RELEASE_POSSIBLE_LOCK` used here is a macro which deals with the lock
+needed to patch the code. This lock is necessary since STklos permits to
+have several threads to execute the same code. All the stuff about locking in
+the VM is explained in `vm.c` source file, and is covered (a bit) below.
-Of course, this is also done in all other `UGREF_*` instructions in a
-similar way.
+Of course, all the work detailed about how we optimize access to global
+variables is also done in all other `UGREF_*` instructions in a similar way.
That is why, even using a hash table, access to global variables happens
with speed not too far from that of access to local variables in STklos.
@@ -612,7 +649,7 @@ This can be seen in the following rudimentary benchmark:
(set! a b))))
;;;
-;;; Using globals: in the same system, runs in about 4000ms
+;;; Using globals: runs in about the same time (probably a bit faster)
;;;
(define a 0)
(define b 2)
@@ -1470,21 +1507,24 @@ Already covered before:
=== The global lock
-There is one global mutex lock for STklos, called `global_lock`, declared in `vm.c`:
-
-`MUT_DECL(global_lock); /* the lock to access checked_globals */`
+There is one global mutex lock for STklos, called `global_code_lock`, declared in `vm.c`:
-As per the comment, its purpose is to discipline access to global variables.
+`MUT_DECL(global_code_lock); /* Lock to permit code patching */`
+As per the comment, its purpose is to discipline access to the instructions of
+the running program. This lock is used when patching code for optimizing
+further global variables accesses (as explained before). This is necessary since
+STklos can use several threads. Note that each Scheme thread use its own
+VM, but the code and the global variables are shared among all the threads.
Three macros are used to control the global lock (a mutex):
* `LOCK_AND_RESTART` will acquire the lock, and decrease the program counter.
-It will also set a flag that signals that the lock has been acquired by this thread,
-and then call `NEXT`.
-The name "`AND_RESTART`" reflects the fact that it decreases the PC and calls `NEXT`
-(for the next instruction) -- so the effect is to start again operating on this
-instruction, but this time with the lock.
+It will also set a flag that signals to the running VM that the lock has been
+acquired by this thread, and then call `NEXT`. The name "`AND_RESTART`"
+reflects the fact that it decreases the PC and calls `NEXT` (for the next
+instruction) -- so the effect is to start again operating on this instruction,
+but this time with the lock.
* `RELEASE_LOCK` will release the lock, regardless of the thread having it or not. The flag indicating ownership by this thread is cleared.
diff --git a/lib/Makefile.am b/lib/Makefile.am
index de1c6d894..89aa2e899 100644
--- a/lib/Makefile.am
+++ b/lib/Makefile.am
@@ -73,7 +73,6 @@ SRC_STK = bigmatch.stk \
expand.ss \
full-syntax.stk \
getopt.stk \
- help.stk \
lex-rt.stk \
make-C-boot.stk \
pretty-print.stk \
@@ -87,7 +86,6 @@ scheme_OBJS = bigmatch.ostk \
describe.ostk \
env.ostk \
getopt.ostk \
- help.ostk \
lex-rt.ostk \
pretty-print.ostk \
slib.ostk \
diff --git a/lib/Makefile.in b/lib/Makefile.in
index 6b990d882..91f930060 100644
--- a/lib/Makefile.in
+++ b/lib/Makefile.in
@@ -439,7 +439,6 @@ SRC_STK = bigmatch.stk \
expand.ss \
full-syntax.stk \
getopt.stk \
- help.stk \
lex-rt.stk \
make-C-boot.stk \
pretty-print.stk \
@@ -452,7 +451,6 @@ scheme_OBJS = bigmatch.ostk \
describe.ostk \
env.ostk \
getopt.ostk \
- help.ostk \
lex-rt.ostk \
pretty-print.ostk \
slib.ostk \
diff --git a/lib/autoloads.stk b/lib/autoloads.stk
index 741a78eec..57e7ba54b 100644
--- a/lib/autoloads.stk
+++ b/lib/autoloads.stk
@@ -45,7 +45,7 @@
(autoload "getopt" %parse-arguments-expand %print-usage)
(autoload "trace" %trace-expand %untrace-expand)
(autoload "pretty-print" pp pretty-print)
-(autoload "help" help)
+(autoload "stklos/help" help)
(autoload "lex-rt" lexer-next-token)
(autoload "srfi/27" random-integer random-real)
(autoload "srfi/48" srfi48:help srfi48:format-fixed)
diff --git a/lib/bonus.stk b/lib/bonus.stk
index 0f70a5dae..a57fbef66 100644
--- a/lib/bonus.stk
+++ b/lib/bonus.stk
@@ -57,6 +57,7 @@
error-object-location %push-id %stable-version?
define-constant
void?
+ default-browser open-in-browser manual man
receive case-lambda
radians->degrees degrees->radians
@@ -430,20 +431,18 @@ doc>
doc>
|#
-(define command-line
- (let* ((script-file (key-get *%system-state-plist* :script-file ""))
- (cmd-line (cons (if (equal? script-file "")
- ""
- (key-get *%system-state-plist* :program-name ""))
- (key-get *%system-state-plist* :argv '()))))
- (define (verify-setter val)
- (if (and (list? val)
- (not (null? val))
- (every string? val))
- val
- (error "bad command line ~S" val)))
-
- (make-parameter cmd-line verify-setter)))
+(define-parameter command-line
+ (let ((script-file (key-get *%system-state-plist* :script-file "")))
+ (cons (if (equal? script-file "")
+ ""
+ (key-get *%system-state-plist* :program-name ""))
+ (key-get *%system-state-plist* :argv '())))
+ (lambda (val)
+ (if (and (list? val)
+ (not (null? val))
+ (every string? val))
+ val
+ (error 'command-line "bad command line ~S" val))))
#|
@@ -1871,6 +1870,80 @@ doc>
(* (/ d 180)
3.141592653589793115997963468544185161590576171875)) ; pi
+
+;;;;
+;;;; Browser & Manual
+;;;;
+
+
+#|
+
+|#
+(define-parameter default-browser
+ (cond
+ ((getenv "STKLOS_BROWSER"))
+ ((getenv "BROWSER"))
+ ((equal? (os-name) "Darwin") "open")
+ (else "xdg-open"))
+ (lambda (v)
+ (if (not (string? v))
+ (error 'default-browser "bad browser name ~s" v)
+ v)))
+
+#|
+
+|#
+(define (open-in-browser url)
+ (let ((cmd (format "~a '~a'" (default-browser) url)))
+ (when (positive? (stklos-debug-level))
+ (eprintf (format "Running command ~s\n" cmd)))
+ (system cmd)))
+
+
+#|
+
+|#
+(define (manual :optional complement)
+ (let* ((fn (make-path (install-path #:htmldir)
+ "stklos-ref.html"))
+ (comp (format "~a" complement)) ;; -> string
+ (base (if (file-exists? fn)
+ (string-append "file://" fn)
+ "https://stklos.net/Doc/HTML/stklos-ref.html")))
+ (open-in-browser (if complement
+ (string-append base "#P_" comp)
+ base))))
+
+;; Use the usual abbreviation for manual
+(define man manual)
+
;;;
;;; Misc
;;;
@@ -1882,6 +1955,8 @@ doc>
(format "unstable -- ~a" commit)
"unstable"))))
+
+
;;;; ======================================================================
;;;;
;;;; SRFIs support
diff --git a/lib/boot.stk b/lib/boot.stk
index 0c5fd863a..f3d7a89e5 100644
--- a/lib/boot.stk
+++ b/lib/boot.stk
@@ -65,7 +65,9 @@
(include "equiv.stk") ; equivalence of circular structures
(include "time.stk") ; Dates & Time
(include "logical.stk") ; Logical operations
- (include "thread.stk") ; Thread support
+ (unless (eq? (%thread-system)
+ 'none)
+ (include "thread.stk")) ; Thread support
(include "ffi.stk") ; FFI support
(include "r7rs.stk") ; Support of R7RS
(include "load.stk") ; Extended load dealing with paths and suffixes
diff --git a/lib/compflags.stk b/lib/compflags.stk
index d57122c83..0e18d5ac0 100644
--- a/lib/compflags.stk
+++ b/lib/compflags.stk
@@ -30,7 +30,8 @@
;; Compiler parameters ...
;; ----------------------------------------------------------------------
-(export compiler:time-display
+(export define-parameter
+ compiler:time-display
compiler:gen-line-number
compiler:warn-use-undefined
compiler:warn-use-undefined-postpone
@@ -167,20 +168,28 @@ doc>
* |n| must be a positive integer.
doc>
|#
-(define compiler:time-display (make-parameter #t))
-(define compiler:gen-line-number (make-parameter #f))
-(define compiler:warn-use-undefined (make-parameter #f))
-(define compiler:warn-use-undefined-postpone (make-parameter #t))
-(define compiler:show-assembly-code (make-parameter #f))
-(define compiler:keep-formals (make-parameter #f))
-(define compiler:keep-source (make-parameter #f))
-(define compiler:unroll-iterations
- (make-parameter 4
- (lambda (v)
- (unless (and (fixnum? v) (positive? v))
- (error 'compiler:unroll-iterations
- "must be a positive fixnum. It was ~s" v))
- v)))
+(define-parameter compiler:time-display #t)
+(define-parameter compiler:gen-line-number #f)
+(define-parameter compiler:warn-use-undefined #f)
+(define-parameter compiler:warn-use-undefined-postpone #t)
+(define-parameter compiler:show-assembly-code #f)
+(define-parameter compiler:keep-formals #f)
+(define-parameter compiler:keep-source #f)
+(define-parameter compiler:unroll-iterations 4
+ (lambda (v)
+ (unless (and (fixnum? v) (positive? v))
+ (error 'compiler:unroll-iterations
+ "must be a positive fixnum. It was ~s" v))
+ v))
+
+(define compiler:inline-common-functions
+ (let* ((inlined *inline-symbols*)
+ (res (make-parameter #t
+ (lambda (v)
+ (set! *inline-symbols* (if v inlined '()))
+ (not (null? *inline-symbols*))))))
+ (%set-parameter-name! res 'compiler:inline-common-functions)
+ res))
;; ----------------------------------------------------------------------
;; %compiler-set-flags ...
diff --git a/lib/compiler.stk b/lib/compiler.stk
index b37c365f0..b8e864d33 100644
--- a/lib/compiler.stk
+++ b/lib/compiler.stk
@@ -229,20 +229,12 @@
;; ======================================================================
-(define compiler:inline-common-functions
- (let ((inlined *inline-symbols*))
- (make-parameter #t
- (lambda (v)
- (set! *inline-symbols* (if v inlined '()))
- (not (null? *inline-symbols*))))))
-
-(define compiler-current-module
- (make-parameter (current-module)
- (lambda (new)
- (unless (module? new)
- (error 'compiler-current-module "bad module parameter ~s" new))
- (add-file-module-list! new)
- new)))
+(define-parameter compiler-current-module (current-module)
+ (lambda (new)
+ (unless (module? new)
+ (error 'compiler-current-module "bad module parameter ~s" new))
+ (add-file-module-list! new)
+ new))
;; ----------------------------------------------------------------------
diff --git a/lib/load.stk b/lib/load.stk
index 5a421297e..c5d003181 100644
--- a/lib/load.stk
+++ b/lib/load.stk
@@ -23,7 +23,7 @@
;;;; Creation date: 17-May-2000 14:55 (eg)
;;;;
-(export build-path-from-shell-variable
+(export build-path-from-shell-variable install-path
load-path load-suffixes load-verbose current-loading-file
try-load load
find-path
@@ -50,15 +50,15 @@
;;
;; stklos-conf-file: returns an absolute name for the given configuration file
;;
-(define %stklos-conf-dir
- (make-parameter (let ((old-path (make-path (getenv "HOME") ".stklos"))
- (xdg-conf (getenv "XDG_CONFIG_HOME")))
- (or (getenv "STKLOS_CONFDIR")
- (if (file-exists? old-path)
- old-path
- (make-path (or xdg-conf "~/.config")
- "stklos"))))
- expand-file-name))
+(define-parameter %stklos-conf-dir
+ (let ((old-path (make-path (getenv "HOME") ".stklos"))
+ (xdg-conf (getenv "XDG_CONFIG_HOME")))
+ (or (getenv "STKLOS_CONFDIR")
+ (if (file-exists? old-path)
+ old-path
+ (make-path (or xdg-conf "~/.config")
+ "stklos"))))
+ expand-file-name)
(define (%stklos-conf-file name)
(make-path (%stklos-conf-dir) name))
@@ -118,19 +118,18 @@ doc>
* current list of paths.
doc>
|#
-(define load-path
- (make-parameter *load-path*
- (lambda (new-path)
- ;; Sanity check
- (unless (list? new-path)
- (error 'load-path "bad list of path names ~S" new-path))
- (for-each (lambda (x)
- (unless (string? x)
- (error 'load-path "bad path name ~S" x)))
- new-path)
- ;; Set the load path
- (set! *load-path* new-path)
- new-path)))
+(define-parameter load-path *load-path*
+ (lambda (new-path)
+ ;; Sanity check
+ (unless (list? new-path)
+ (error 'load-path "bad list of path names ~S" new-path))
+ (for-each (lambda (x)
+ (unless (string? x)
+ (error 'load-path "bad path name ~S" x)))
+ new-path)
+ ;; Set the load path
+ (set! *load-path* new-path)
+ new-path))
#|
* until the file can be loaded.
doc>
|#
-(define load-suffixes
- (make-parameter *load-suffixes*
- (lambda (new)
- ;; Sanity check
- (unless (list? new)
- (error 'load-path "bad list of suffixes ~S" new))
- (for-each (lambda (x)
- (unless (string? x)
- (error 'load-path "bad path name ~S" x)))
- new)
- ;; Set the load suffixes
- (set! *load-suffixes* new)
- new)))
+(define-parameter load-suffixes *load-suffixes*
+ (lambda (new)
+ ;; Sanity check
+ (unless (list? new)
+ (error 'load-path "bad list of suffixes ~S" new))
+ (for-each (lambda (x)
+ (unless (string? x)
+ (error 'load-path "bad path name ~S" x)))
+ new)
+ ;; Set the load suffixes
+ (set! *load-suffixes* new)
+ new))
#|
* is set to `#f`, no message is printed.
doc>
|#
-(define load-verbose
- (make-parameter *load-verbose*
- (lambda (x) (set! *load-verbose* (and x #t)) *load-verbose*)))
+(define-parameter load-verbose *load-verbose*
+ (lambda (x) (set! *load-verbose* (and x #t)) *load-verbose*))
#|
|#
-(define current-loading-file
- (make-parameter #f))
+(define-parameter current-loading-file #f)
+
+
+
+#|
+
+|#
+;; NOTE: placed here because other returnning path functions are here, but this
+;; function is not really related to load.
+(define (install-path :optional key)
+ (let ((dirs (key-get (%stklos-configure) #:dirs #f)))
+ (unless dirs
+ (error 'install-path "cannot find configuration description"))
+ (if key
+ (begin
+ (unless (keyword? key)
+ (error 'install-path "bad keyword ~S" key))
+ (let ((val (key-get dirs key #f)))
+ (unless val
+ (error 'install-path "cannot find directory for key ~S" key))
+ val))
+ dirs)))
;=============================================================================
@@ -365,7 +396,7 @@ doc>
(define provided? #f)
(define require/provide #f)
-(define warning-when-not-provided (make-parameter #t))
+(define-parameter warning-when-not-provided #t) ;; FIXME: document it
#| HACK: FIXME:
@@ -538,4 +569,3 @@ doc>
symbols))))
; LocalWords: repl autoload prepended
-
diff --git a/lib/readline-complete.c b/lib/readline-complete.c
index e51ab1d18..e62435123 100644
--- a/lib/readline-complete.c
+++ b/lib/readline-complete.c
@@ -52,6 +52,7 @@ extern int rl_attempted_completion_over; // 1 to suppress filename comple
extern char *rl_completer_word_break_characters;// word separator. Normally "n\"\\'`@$>"
extern rl_completion_func_t *rl_attempted_completion_function; // Pointer to our completion func
+extern char* rl_readline_name; // NOTE: not completion related (see below)
static SCM gen; // A pointer to the Scheme generator function
@@ -131,6 +132,12 @@ MODULE_ENTRY_START("readline-complete")
SCM module = STk_STklos_module; // FIXME: should be READLINE
ADD_PRIMITIVE_IN_MODULE(readline_init_completion, module);
+
+ // NOTE: the following assignment is not related to completion and should not be here.
+ // However since our FFI doesn't permit to read/set variables and since this is the only
+ // file written in C interacting with readline, we do this assignment here.
+ // It permits to have STklos specific parts in the ~/.inputrc file
+ rl_readline_name = "stklos";
}
MODULE_ENTRY_END
diff --git a/lib/readline.stk b/lib/readline.stk
index 959df8d12..3dfa0fbb5 100644
--- a/lib/readline.stk
+++ b/lib/readline.stk
@@ -129,7 +129,7 @@
;; The parameter rl-completer-function contains the function used
;; to complete strings It defaults to default-complete-function
-(define rl-completer-function (make-parameter default-complete-function))
+(define-parameter rl-completer-function default-complete-function)
#|
As an example, here is another completer function. This one tries to find
diff --git a/lib/repl.stk b/lib/repl.stk
index 57d626578..576a1a392 100644
--- a/lib/repl.stk
+++ b/lib/repl.stk
@@ -34,7 +34,8 @@
(export main-repl repl repl-prompt repl-make-prompt repl-display-prompt
repl-prompt-use-color? repl-change-default-ports main-repl-hook
repl-theme get-repl-color repl-show-startup-message
- repl-add-command)
+ repl-add-command
+ @ @1 @2 @3 @4 @5 @*)
;;; In module REPL
@@ -47,6 +48,14 @@
(define default-out (current-output-port))
(define default-err (current-error-port))
+(define @ #void)
+(define @1 #void)
+(define @2 #void)
+(define @3 #void)
+(define @4 #void)
+(define @5 #void)
+(define @* (list @1 @2 @3 @4 @5))
+
#|
(minimal . (:error (bold red)
:prompt underline))))
-(define repl-theme
- (make-parameter #f
- (lambda (theme)
- (if (symbol? theme)
- (let ((val (assoc theme *repl-themes*)))
- (if val (cdr val) '()))
- theme))))
+(define-parameter repl-theme #f
+ (lambda (theme)
+ (if (symbol? theme)
+ (let ((val (assoc theme *repl-themes*)))
+ (if val (cdr val) '()))
+ theme)))
(define (get-repl-color key)
(key-get (repl-theme) key ""))
@@ -118,12 +126,67 @@ doc>
;;; ======================================================================
(define *repl-commands* '())
+#|
+/dev/null")))))
+ * @end lisp
+ *
+ * NOTE: {{stklos}} has already a number of commands defined, but |repl-add-command| can be
+ * useful to define you own command. A good place to add such a definition is in the
+ * |stklosrc| file.
+doc>
+|#
(define (repl-add-command names doc func)
- (let ((names (if (symbol? names) (list names) names)))
- (set! *repl-commands* (cons (list names doc func)
- *repl-commands*))))
-
-(define (do-repl-command l)
+ (let* ((names (if (symbol? names) (list names) names))
+ (old (assoc names *repl-commands*)))
+ (if old
+ (set-cdr! old (list doc func)) ;; already present. Replace.
+ (set! *repl-commands* (cons (list names doc func)
+ *repl-commands*)))))
+
+(define (display-repl-command-help)
+ (let* ((lines (map (lambda (x)
+ (let ((out (open-output-string)))
+ (for-each (lambda (c) (fprintf out ",~a " c))
+ (car x))
+ (cons (get-output-string out) (cadr x))))
+ *repl-commands*))
+ (max-len (apply max (map string-length (map car lines)))))
+
+ ;; Print all the lines aligned on max-len characters
+ (display (do-color (get-repl-color :help) "Available commands:\n"))
+ (display (do-color 'normal))
+ (for-each (lambda (x)
+ (print " - "
+ (car x)
+ (make-string (- max-len (string-length (car x)))
+ #\space)
+ " "
+ (cdr x)))
+ (reverse lines))) ;; to keep the declaration order
+
+ ;; Print somme helps on the @ variables
+ (display (do-color (get-repl-color :help) "\nAvailable variables:\n"))
+ (display (do-color 'normal))
+ (display "If not redefined by your program, the following variables are available\n")
+ (display " - @1 (aka @), @2, @3, @4, @5 contain the last REPL's computed values\n")
+ (display " - @* contains a list of @1, @2, @3, @4 and @5 values\n"))
+
+(define (do-repl-command name)
(define (search-repl-command name)
(let Loop ((lst *repl-commands*))
(if (pair? lst)
@@ -134,7 +197,7 @@ doc>
(Loop (cdr lst))))
;; List of possibilities exhausted
(format (current-error-port)
- "bad command name: '~s'.\nType ,help for some help\n"
+ "bad command name: '~s'.\nType ',help' for some help.\n"
name))))
;; Skip the leading spaces
@@ -143,53 +206,96 @@ doc>
(read-char)
(Loop)))
- ;; And try to find a REPL command
- (search-repl-command (car l)))
-
-;; ==== backtrace
-(repl-add-command '(backtrace bt)
- "Show the stack when last error occurred"
- (lambda () (%display-backtrace repl-backtrace 6)))
-;; ==== cd
-(repl-add-command 'cd
- "Change current directory"
- (lambda () (chdir (read-line))))
-;; ==== pwd
-(repl-add-command 'pwd
- "Print working directory"
- (lambda () (printf "~s~%" (getcwd))))
-;; ==== quit
-(repl-add-command '(quit q)
- "Exit STklos"
- (lambda () (exit 0)))
-;; ==== shell
-(repl-add-command '(shell !)
- "Run a shell command"
- (lambda () (system (read-line))))
-;; ==== help
-(repl-add-command
+ ;; And try to find a REPL command
+ (search-repl-command name))
+
+
+;; A simple trim for the commands below
+(let ((simple-trim (lambda (str)
+ (regexp-replace "\\s*$"
+ (regexp-replace "^\\s*" str "")
+ ""))))
+
+ ;; ==== backtrace
+ (repl-add-command '(backtrace bt)
+ "Show the stack when last error occurred"
+ (lambda () (%display-backtrace repl-backtrace 6)))
+ ;; ==== cd
+ (repl-add-command 'cd
+ "Change current directory"
+ (lambda () (chdir (simple-trim (read-line)))))
+ ;; ==== pwd
+ (repl-add-command 'pwd
+ "Print working directory"
+ (lambda () (printf "~s~%" (getcwd))))
+
+ ;; ==== ls
+ (repl-add-command 'ls
+ "List directory content"
+ (lambda () (system (string-append "ls " (read-line)))))
+
+ ;; ==== quit
+ (repl-add-command '(quit q)
+ "Exit STklos"
+ (lambda () (exit 0)))
+ ;; ==== shell
+ (repl-add-command '(shell !)
+ "Run a shell command"
+ (lambda () (system (read-line))))
+ ;; ==== time
+ (repl-add-command '(time t)
+ "Print the time used to run the next expression"
+ (lambda () (printf "~w~%" (eval-from-string
+ (format "(time (eval '~a))" (read))))))
+ ;; ==== describe
+ (repl-add-command '(describe d)
+ "Describe an object"
+ (lambda () (describe (eval (read)))))
+ ;; ==== expand
+ (repl-add-command '(expand e)
+ "Pretty print the macro expansion of a form"
+ (lambda () (pretty-print (macro-expand (read)))))
+ ;; ==== import
+ (repl-add-command '(import i)
+ "Import a library"
+ (lambda () (eval-from-string (format "(import ~a)" (read)))))
+ ;; == require-feature
+ (repl-add-command '(require-feature r)
+ "Require a feature"
+ (lambda () (require-feature (read))))
+ ;; ==== open
+ (repl-add-command '(open o)
+ "Open file or URL"
+ (lambda ()
+ (let ((cmd (if (equal? (os-name) "Darwin") "open" "xdg-open")))
+ (system (string-append cmd " " (read-line) " 2>/dev/null")))))
+ ;; ==== describe
+ (repl-add-command '(describe d)
+ "Describe an object"
+ (lambda () (describe (eval (read)))))
+ ;; ==== manual
+ (repl-add-command '(manual m)
+ "Search reference manual"
+ (lambda () (manual (simple-trim (read-line)))))
+ ;; ==== apropos
+ (repl-add-command '(apropos a)
+ "Search for symbols containing a given string"
+ (lambda () (print (apropos (simple-trim (read-line))))))
+ ;; ==== help
+ (repl-add-command
'(help ? h)
- "This help"
+ "This help if no parameter, or help on its argument"
(lambda ()
- (let* ((lines (map (lambda (x)
- (let ((out (open-output-string)))
- (for-each (lambda (c) (fprintf out ",~a " c))
- (car x))
- (cons (get-output-string out) (cadr x))))
- *repl-commands*))
- (max-len (apply max (map string-length (map car lines)))))
-
- (display (do-color (get-repl-color :help) "Available Commands:\n"))
- ;; Print all the lines aligned on max-len characters
- (for-each (lambda (x)
- (print "- "
- (car x)
- (make-string (- max-len (string-length (car x)))
- #\space)
- " "
- (cdr x)))
- (reverse lines)))
- (display (do-color 'normal))))
+ (let ((arg (read-line)))
+ (if (equal? arg "")
+ (display-repl-command-help)
+ (help (read-from-string arg))))))
+
+ ;; == version
+ (repl-add-command '(version v)
+ "Show version"
+ (lambda () (printf "~a ~a~%" (version) (%push-id))))
+) ;; end of REPL commands
;; ----------------------------------------------------------------------
;; repl-handler ...
@@ -253,12 +359,12 @@ doc>
;; ----------------------------------------------------------------------
;; repl-prompt ...
;; ----------------------------------------------------------------------
-(define repl-prompt (make-parameter ""))
+(define-parameter repl-prompt "")
;; ----------------------------------------------------------------------
;; repl-prompt-use-color? ...
;; ----------------------------------------------------------------------
-(define repl-prompt-use-color? (make-parameter #t))
+(define-parameter repl-prompt-use-color? #t)
;; ----------------------------------------------------------------------
;; make-prompt ...
@@ -277,7 +383,7 @@ doc>
;; ----------------------------------------------------------------------
;; repl-make-prompt ...
;; ----------------------------------------------------------------------
-(define repl-make-prompt (make-parameter make-prompt))
+(define-parameter repl-make-prompt make-prompt)
;; ----------------------------------------------------------------------
;; display-prompt ...
@@ -289,7 +395,7 @@ doc>
;; ----------------------------------------------------------------------
;; repl-display-prompt ...
;; ----------------------------------------------------------------------
-(define repl-display-prompt (make-parameter display-prompt))
+(define-parameter repl-display-prompt display-prompt)
#|
@@ -306,13 +412,13 @@ doc>
* `stklosrc` file.
doc>
|#
-(define repl-show-startup-message
- (make-parameter (key-get *%system-state-plist* #:startup-message #t)))
+(define-parameter repl-show-startup-message
+ (key-get *%system-state-plist* #:startup-message #t))
;; ----------------------------------------------------------------------
;; main-repl-hook ...
;; ----------------------------------------------------------------------
-(define main-repl-hook (make-parameter void))
+(define-parameter main-repl-hook void)
;; ----------------------------------------------------------------------
;; repl-change-default-ports ...
@@ -362,7 +468,7 @@ doc>
(flush-output-port out))
((and (pair? e) (eq? (car e) 'unquote))
- (do-repl-command (cdr e)))
+ (do-repl-command (cadr e)))
(else
(call-with-values
@@ -381,7 +487,25 @@ doc>
'normal)
out)))
(else
- (for-each (lambda (x) (write-shared x out) (newline out))
+ ;; Build @* REPl variable
+ (case (length v)
+ ((1) (set! @* (list (car v) @1 @2 @3 @4)))
+ ((2) (set! @* (list (car v) (cadr v) @1 @2 @3)))
+ ((3) (set! @* (list (car v) (cadr v) (caddr v) @1 @2)))
+ ((4) (set! @* (list (car v) (cadr v) (caddr v) (cadddr v)
+ @1)))
+ (else (set! @* (list (car v) (cadr v) (caddr v) (cadddr v)
+ (car (cddddr v))))))
+ ;; Build @i variables
+ (set! @5 (car (cddddr @*)))
+ (set! @4 (cadddr @*))
+ (set! @3 (caddr @*))
+ (set! @2 (cadr @*))
+ (set! @1 (car @*))
+ (set! @ @1) ; @ is an alias on @1
+
+ ;; Print values
+ (for-each (lambda (x) (write-shared x out) (newline out))
v)))
(flush-output-port out))))))))
;; Loop if we have not meet an EOF
diff --git a/lib/runtime.stk b/lib/runtime.stk
index 296081b76..e9643a1fd 100644
--- a/lib/runtime.stk
+++ b/lib/runtime.stk
@@ -166,6 +166,29 @@ doc>
;; ----------------------------------------------------------------------
;; parameters
;; ----------------------------------------------------------------------
+;; ----------------------------------------------------------------------
+;; define-parameter
+;; ----------------------------------------------------------------------
+#|
+
+|#
+(define-macro (define-parameter name . args)
+ (if (<= 1 (length args) 2)
+ (let ((tmp (gensym 'param)))
+ `(define ,name (let ((,tmp (make-parameter ,@args)))
+ (%set-parameter-name! ,tmp ',name)
+ ,tmp)))
+ (syntax-error 'define-parameter
+ "bad number of arguments (must be 2 or 3)")))
+
+
+
#|
* |stklos(1)| command.
doc>
|#
-(define stklos-debug-level
- (make-parameter 0))
+(define-parameter stklos-debug-level 0
+ (lambda (x)
+ (if (integer? x) x (error 'stklos-debug-level "bad integer" x))))
;; ----------------------------------------------------------------------
;; management of globals ...
;; ----------------------------------------------------------------------
;; This should be in compiler module but it a nightmare with bootstrap.
-(define compiler-known-globals
- (make-parameter '()))
+(define-parameter compiler-known-globals '())
(define (register-new-global! symbol)
(let ((lst (compiler-known-globals)))
diff --git a/lib/srfi/18.stk b/lib/srfi/18.stk
index 0774a7157..bee466790 100644
--- a/lib/srfi/18.stk
+++ b/lib/srfi/18.stk
@@ -2,7 +2,7 @@
;;;;
;;;; 18.stk -- Implementation of the (srfi 18) library
;;;;
-;;;; Copyright © 2021-2022 Erick Gallesio - I3S-CNRS/Polytech Nice-Sophia
+;;;; Copyright © 2021-2023 Erick Gallesio
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
@@ -25,7 +25,10 @@
;;;;
-(define-module srfi/18
+(define-module srfi/18)
+
+(unless (eq? (%thread-system) 'none)
+ (select-module srfi/18)
(import (only SCHEME
current-thread thread? make-thread
thread-name thread-specific thread-specific-set!
@@ -70,29 +73,7 @@
uncaught-exception?
uncaught-exception-reason)
-;;// ;; SRFI-18 is embedded in STklos; Redefine functions here
-;;// (%module-define-and-export
-;;// current-thread thread? make-thread
-;;// thread-name thread-specific thread-specific-set!
-;;// thread-start! thread-yield! thread-sleep!
-;;// thread-terminate! thread-join!
-;;// mutex? make-mutex mutex-name
-;;// mutex-specific mutex-specific-set!
-;;// mutex-state mutex-lock! mutex-unlock!
-;;// condition-variable? make-condition-variable
-;;// condition-variable-name condition-variable-specific
-;;// condition-variable-specific-set!
-;;// condition-variable-signal!
-;;// condition-variable-broadcast!
-;;// current-time time? time->seconds
-;;// seconds->time current-exception-handler
-;;// with-exception-handler
-;;// raise
-;;// join-timeout-exception?
-;;// abandoned-mutex-exception?
-;;// terminated-thread-exception?
-;;// uncaught-exception?
-;;// uncaught-exception-reason)
+
)
diff --git a/lib/srfi/216.stk b/lib/srfi/216.stk
index c300cadda..7b2c1c595 100644
--- a/lib/srfi/216.stk
+++ b/lib/srfi/216.stk
@@ -2,7 +2,7 @@
;;;;
;;;; srfi-216.stk -- SRFI-116: SICP Prerequisites
;;;;
-;;;; Copyright © 2021-2022 Erick Gallesio - I3S-CNRS/Polytech Nice-Sophia
+;;;; Copyright © 2021-2023 Erick Gallesio
;;;;
;;;;
;;;; This program is free software; you can redistribute it and/or modify
@@ -57,26 +57,36 @@
;; ======================================================================
;; Multi-threading
;; ======================================================================
-(unless (eq? (%thread-system) 'none)
- (define (parallel-execute . procs)
- (let ((threads (map (lambda (p) (thread-start! (make-thread p)))
- procs)))
- (for-each thread-join! threads)))
- ;; tests-and-set!
- (define test-and-set! #f)
+;; define parallel-execute and test-and-set! to #f. They will be changed if
+;; STklos is compiled with thread support
+(define parallel-execute #f)
+(define test-and-set! #f)
- (let ((mutex(make-mutex)))
- (set! test-and-set!
- (lambda (cell)
- (mutex-lock! mutex)
- (let ((result (if (car cell)
- #t
- (begin (set-car! cell #t)
- #f))))
- (mutex-unlock! mutex)
- result)))))
+(case (%thread-system)
+ ((none)
+ ;; No thread support
+ (set! parallel-execute %thread-no-support)
+ (set! test-and-set! %thread-no-support))
+ (else
+ ;; We have thread support
+ (set! parallel-execute
+ (lambda procs
+ (let ((threads (map (lambda (p) (thread-start! (make-thread p)))
+ procs)))
+ (for-each thread-join! threads))))
+
+ (let ((mutex(make-mutex)))
+ (set! test-and-set!
+ (lambda (cell)
+ (mutex-lock! mutex)
+ (let ((result (if (car cell)
+ #t
+ (begin (set-car! cell #t)
+ #f))))
+ (mutex-unlock! mutex)
+ result))))))
;; ======================================================================
;; Streams.
@@ -91,4 +101,3 @@
;;;; ======================================================================
(provide "srfi/216")
-
diff --git a/lib/srfi/230.stk b/lib/srfi/230.stk
index a77702e5c..bff3cdc98 100644
--- a/lib/srfi/230.stk
+++ b/lib/srfi/230.stk
@@ -20,7 +20,11 @@
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
;; SOFTWARE.
-(define-module srfi/230
+
+(define-module srfi/230)
+
+(unless (eq? (%thread-system) 'none)
+ (select-module srfi/230)
(export memory-order
memory-order?
make-atomic-flag
@@ -52,196 +56,196 @@
atomic-pair-compare-and-swap!
atomic-fence)
(import ;;(scheme base)
- ;;(scheme case-lambda)
- ;;(srfi 9)
- (srfi 18)
- ;;(srfi 143) no need, it's STklos native!
- )
-
- ;; Internals
-
- (define lock (make-mutex))
-
- (define-syntax lock-guard
- (syntax-rules ()
- ((lock-guard . body)
- (dynamic-wind
- (lambda ()
- (guard
- (c
- ((abandoned-mutex-exception? c)
- #f))
- (mutex-lock! lock)))
- (lambda () . body)
- (lambda ()
- (mutex-unlock! lock))))))
-
- ;; Memory orders
-
- ;; Note: On an R6RS system, the following syntax and procedure would be
- ;; implemented as an enumeration type.
-
- (define-syntax memory-order
- (syntax-rules ()
- ((memory-order symbol) 'symbol)))
-
- (define (memory-order? obj)
- (and (memq
- obj
- '(relaxed acquire release acquire-release sequentially-consistent))
- #t))
-
- ;; Atomic flags
-
- (define-record-type atomic-flag
- (%make-atomic-flag content)
- atomic-flag?
- (content atomic-flag-content atomic-flag-set-content!))
-
- (define (make-atomic-flag)
- (%make-atomic-flag #f))
-
- (define (atomic-flag-test-and-set! flag . o)
- (lock-guard
- (let ((prev (atomic-flag-content flag)))
- (atomic-flag-set-content! flag #t)
- prev)))
-
- (define (atomic-flag-clear! flag . o)
- (lock-guard
- (atomic-flag-set-content! flag #f)))
-
- ;; Atomic boxes
-
- (define-record-type atomic-box
- (make-atomic-box content)
- atomic-box?
- (content atomic-box-content atomic-box-set-content!))
-
- (define (atomic-box-ref box . o)
- (lock-guard
- (atomic-box-content box)))
-
- (define (atomic-box-set! box obj . o)
- (lock-guard
- (atomic-box-set-content! box obj)))
-
- (define (atomic-box-swap! box obj . o)
- (lock-guard
- (let ((prev (atomic-box-content box)))
- (atomic-box-set-content! box obj)
- prev)))
-
- (define (atomic-box-compare-and-swap! box expected desired . o)
- (lock-guard
- (let ((actual (atomic-box-content box)))
- (when (eq? expected actual)
- (atomic-box-set-content! box desired))
- actual)))
-
- ;; Atomic fixnum boxes
-
- (define-record-type atomic-fxbox
- (make-atomic-fxbox content)
- atomic-fxbox?
- (content atomic-fxbox-content atomic-fxbox-set-content!))
-
- (define (atomic-fxbox-ref box . o)
- (lock-guard
- (atomic-fxbox-content box)))
-
- (define (atomic-fxbox-set! box obj . o)
- (lock-guard
- (atomic-fxbox-set-content! box obj)))
-
- (define (atomic-fxbox-swap! box obj . o)
- (lock-guard
- (let ((prev (atomic-fxbox-content box)))
- (atomic-fxbox-set-content! box obj)
- prev)))
-
- (define (atomic-fxbox-compare-and-swap! box expected desired . o)
- (lock-guard
- (let ((actual (atomic-fxbox-content box)))
- (when (fx=? expected actual)
- (atomic-fxbox-set-content! box desired))
- actual)))
-
- (define (atomic-fxbox+/fetch! box n . o)
- (lock-guard
- (let ((prev (atomic-fxbox-content box)))
- (atomic-fxbox-set-content! box (fx+ n prev))
- prev)))
-
- (define (atomic-fxbox-/fetch! box n . o)
- (lock-guard
- (let ((prev (atomic-fxbox-content box)))
- (atomic-fxbox-set-content! box (fx- n prev))
- prev)))
-
- (define (atomic-fxbox-and/fetch! box n . o)
- (lock-guard
- (let ((prev (atomic-fxbox-content box)))
- (atomic-fxbox-set-content! box (fxand n prev))
- prev)))
-
- (define (atomic-fxbox-ior/fetch! box n . o)
- (lock-guard
- (let ((prev (atomic-fxbox-content box)))
- (atomic-fxbox-set-content! box (fxior n prev))
- prev)))
-
- (define (atomic-fxbox-xor/fetch! box n . o)
- (lock-guard
- (let ((prev (atomic-fxbox-content box)))
- (atomic-fxbox-set-content! box (fxxor n prev))
- prev)))
-
- ;; Atomic pairs
-
- (define-record-type atomic-pair
- (make-atomic-pair car cdr)
- atomic-pair?
- (car atomic-pair-car atomic-pair-set-car!)
- (cdr atomic-pair-cdr atomic-pair-set-cdr!))
-
- (define (atomic-pair-ref pair . o)
- (lock-guard
- (values
- (atomic-pair-car pair)
- (atomic-pair-cdr pair))))
-
- (define (atomic-pair-set! pair car cdr . o)
- (lock-guard
+ ;;(scheme case-lambda)
+ ;;(srfi 9)
+ (srfi 18)
+ ;;(srfi 143) no need, it's STklos native!
+ )
+
+ ;; Internals
+
+ (define lock (make-mutex))
+
+ (define-syntax lock-guard
+ (syntax-rules ()
+ ((lock-guard . body)
+ (dynamic-wind
+ (lambda ()
+ (guard
+ (c
+ ((abandoned-mutex-exception? c)
+ #f))
+ (mutex-lock! lock)))
+ (lambda () . body)
+ (lambda ()
+ (mutex-unlock! lock))))))
+
+ ;; Memory orders
+
+ ;; Note: On an R6RS system, the following syntax and procedure would be
+ ;; implemented as an enumeration type.
+
+ (define-syntax memory-order
+ (syntax-rules ()
+ ((memory-order symbol) 'symbol)))
+
+ (define (memory-order? obj)
+ (and (memq
+ obj
+ '(relaxed acquire release acquire-release sequentially-consistent))
+ #t))
+
+ ;; Atomic flags
+
+ (define-record-type atomic-flag
+ (%make-atomic-flag content)
+ atomic-flag?
+ (content atomic-flag-content atomic-flag-set-content!))
+
+ (define (make-atomic-flag)
+ (%make-atomic-flag #f))
+
+ (define (atomic-flag-test-and-set! flag . o)
+ (lock-guard
+ (let ((prev (atomic-flag-content flag)))
+ (atomic-flag-set-content! flag #t)
+ prev)))
+
+ (define (atomic-flag-clear! flag . o)
+ (lock-guard
+ (atomic-flag-set-content! flag #f)))
+
+ ;; Atomic boxes
+
+ (define-record-type atomic-box
+ (make-atomic-box content)
+ atomic-box?
+ (content atomic-box-content atomic-box-set-content!))
+
+ (define (atomic-box-ref box . o)
+ (lock-guard
+ (atomic-box-content box)))
+
+ (define (atomic-box-set! box obj . o)
+ (lock-guard
+ (atomic-box-set-content! box obj)))
+
+ (define (atomic-box-swap! box obj . o)
+ (lock-guard
+ (let ((prev (atomic-box-content box)))
+ (atomic-box-set-content! box obj)
+ prev)))
+
+ (define (atomic-box-compare-and-swap! box expected desired . o)
+ (lock-guard
+ (let ((actual (atomic-box-content box)))
+ (when (eq? expected actual)
+ (atomic-box-set-content! box desired))
+ actual)))
+
+ ;; Atomic fixnum boxes
+
+ (define-record-type atomic-fxbox
+ (make-atomic-fxbox content)
+ atomic-fxbox?
+ (content atomic-fxbox-content atomic-fxbox-set-content!))
+
+ (define (atomic-fxbox-ref box . o)
+ (lock-guard
+ (atomic-fxbox-content box)))
+
+ (define (atomic-fxbox-set! box obj . o)
+ (lock-guard
+ (atomic-fxbox-set-content! box obj)))
+
+ (define (atomic-fxbox-swap! box obj . o)
+ (lock-guard
+ (let ((prev (atomic-fxbox-content box)))
+ (atomic-fxbox-set-content! box obj)
+ prev)))
+
+ (define (atomic-fxbox-compare-and-swap! box expected desired . o)
+ (lock-guard
+ (let ((actual (atomic-fxbox-content box)))
+ (when (fx=? expected actual)
+ (atomic-fxbox-set-content! box desired))
+ actual)))
+
+ (define (atomic-fxbox+/fetch! box n . o)
+ (lock-guard
+ (let ((prev (atomic-fxbox-content box)))
+ (atomic-fxbox-set-content! box (fx+ n prev))
+ prev)))
+
+ (define (atomic-fxbox-/fetch! box n . o)
+ (lock-guard
+ (let ((prev (atomic-fxbox-content box)))
+ (atomic-fxbox-set-content! box (fx- n prev))
+ prev)))
+
+ (define (atomic-fxbox-and/fetch! box n . o)
+ (lock-guard
+ (let ((prev (atomic-fxbox-content box)))
+ (atomic-fxbox-set-content! box (fxand n prev))
+ prev)))
+
+ (define (atomic-fxbox-ior/fetch! box n . o)
+ (lock-guard
+ (let ((prev (atomic-fxbox-content box)))
+ (atomic-fxbox-set-content! box (fxior n prev))
+ prev)))
+
+ (define (atomic-fxbox-xor/fetch! box n . o)
+ (lock-guard
+ (let ((prev (atomic-fxbox-content box)))
+ (atomic-fxbox-set-content! box (fxxor n prev))
+ prev)))
+
+ ;; Atomic pairs
+
+ (define-record-type atomic-pair
+ (make-atomic-pair car cdr)
+ atomic-pair?
+ (car atomic-pair-car atomic-pair-set-car!)
+ (cdr atomic-pair-cdr atomic-pair-set-cdr!))
+
+ (define (atomic-pair-ref pair . o)
+ (lock-guard
+ (values
+ (atomic-pair-car pair)
+ (atomic-pair-cdr pair))))
+
+ (define (atomic-pair-set! pair car cdr . o)
+ (lock-guard
+ (atomic-pair-set-car! pair car)
+ (atomic-pair-set-cdr! pair cdr)))
+
+ (define (atomic-pair-swap! pair car cdr . o)
+ (lock-guard
+ (let ((prev-car (atomic-pair-car pair))
+ (prev-cdr (atomic-pair-cdr pair)))
(atomic-pair-set-car! pair car)
- (atomic-pair-set-cdr! pair cdr)))
-
- (define (atomic-pair-swap! pair car cdr . o)
- (lock-guard
- (let ((prev-car (atomic-pair-car pair))
- (prev-cdr (atomic-pair-cdr pair)))
- (atomic-pair-set-car! pair car)
- (atomic-pair-set-cdr! pair cdr)
- (values prev-car prev-cdr))))
-
- (define (atomic-pair-compare-and-swap! pair
- expected-car expected-cdr
- desired-car desired-cdr
- . o)
- (lock-guard
- (let ((actual-car (atomic-pair-car pair))
- (actual-cdr (atomic-pair-cdr pair)))
- (when (and (eq? expected-car actual-car)
- (eq? expected-cdr actual-cdr))
- (atomic-pair-set-car! pair desired-car)
- (atomic-pair-set-cdr! pair desired-cdr))
- (values actual-car actual-cdr))))
-
- ;; Memory synchronization
-
- (define (atomic-fence . o)
- (lock-guard (if #f #f)))
-
-) ;; END of define-module
+ (atomic-pair-set-cdr! pair cdr)
+ (values prev-car prev-cdr))))
+
+ (define (atomic-pair-compare-and-swap! pair
+ expected-car expected-cdr
+ desired-car desired-cdr
+ . o)
+ (lock-guard
+ (let ((actual-car (atomic-pair-car pair))
+ (actual-cdr (atomic-pair-cdr pair)))
+ (when (and (eq? expected-car actual-car)
+ (eq? expected-cdr actual-cdr))
+ (atomic-pair-set-car! pair desired-car)
+ (atomic-pair-set-cdr! pair desired-cdr))
+ (values actual-car actual-cdr))))
+
+ ;; Memory synchronization
+
+ (define (atomic-fence . o)
+ (lock-guard (if #f #f)))
+
+ )
(provide "srfi/230")
diff --git a/lib/srfi/27.stk b/lib/srfi/27.stk
index c042c2075..3549a7e00 100644
--- a/lib/srfi/27.stk
+++ b/lib/srfi/27.stk
@@ -1,8 +1,7 @@
;;;;
-;;;; srfi-27.stk -- SRFI-27: Sources of Random Bits
-;;;;
-;;;; Copyright © 2021 Jeronimo Pellegrini
+;;;; random.stk -- Random numbers (SRFI-27)
;;;;
+;;;; Copyright © 2002-2023 Erick Gallesio
;;;;
;;;; This program is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
@@ -19,250 +18,36 @@
;;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
;;;; USA.
;;;;
-;;;; Author: Jeronimo Pellegrini [j_p@aleph0.info]
-;;;; Creation date: 28-Apr-2021 02:01
+;;;; This implementation is an adaptation of the reference implementation
+;;;; given in the SRFI-27 document made by Sebastian Egner.
+;;;;
+;;;; Author: Sebastian Egner (reference implementation of SRFI-27)
+;;;; Creation date: 10-Aug-2002 17:03 (eg)
+;;;; Last file update: 31-Oct-2023 18:50 (eg)
;;;;
-(select-module srfi/27)
-
-(export default-random-source
- random-integer
- random-real
- random-source-make-integers
- random-source-make-reals
- random-source-state-ref
- random-source-state-set!
- random-source-randomize!
- random-source-pseudo-randomize!
- random-source?
- random-state?
- make-random-source
-
-
-
- )
-
-(define-syntax push!
- (syntax-rules ()
- ((_ e l)
- (set! l (cons e l)))))
-
-(%compile-time-define %make-random-state-mt
- %random-source-pseudo-randomize-mt!
- %random-source-randomize-mt!
- %random-integer-from-source-mt
- %random-real-from-source-mt
- %random-state-copy-mt)
-
-;;
-;; The PRNG algorithms. For now, there is only one (Mersenne Twister),
-;; but we could add others (ChaCha and some MWC variants seem interesting).
-;;
-
-(define *prng-algorithms* '())
-
-;;;
-;;; RANDOM STATE
-;;;
-
-(define-class () ())
-
-(define-generic random-state?)
-(define-method random-state? (obj) #f)
-(define-method random-state? ((st )) #t)
-
-;;;
-;;; RANDOM SOURCE
-;;;
-
-;; The getters and setters begin with "%" because we won't expose
-;; them. They do not copy the state, which is what the user expects and
-;; all implementations do -- they return a *reference* to the state.
-;; So, if the user wanted to "save the state for later", it wouldn't
-;; work, since only pointers were saved, and they point to the state
-;; that is still being modified by number generation.
-(define-class ()
- ((algorithm #:init-keyword #:algorithm)
- (state #:init-keyword #:state
- #:getter %random-source-state-ref
- #:setter %random-source-state-set!)))
-
-
-
-(define-generic make-random-source)
-(define-generic random-source-make-integers)
-(define-generic random-source-make-reals)
-(define-generic random-source-state-ref)
-(define-generic random-source-state-set!)
-(define-generic random-source-randomize!)
-(define-generic random-source-pseudo-randomize!)
-
-(define-method random-source? (obj) #f)
-
-
-(define (make-random-source :optional algo)
- (if algo
- (let ((maker (assq algo *prng-algorithms*)))
- (if maker
- ((cdr maker))
- (error "bad PRNG algorithm ~S" algo)))
- default-random-source)) ;; WRONG! Should make a new one
-
-;;;
-;;; MERSENNE TWISTER
-;;;
-
-;; state
-
-(define-class () ())
-
-(define-reader-ctor '
- (lambda args
- (let ((mti (car args))
- (vec (list->vector (cdr args))))
- (%make-random-state-mt mti vec))))
-
-
-;; Assert that when we create a "random-state-mt" structure, it is
-;; an instance of . Otherwise some generic methods
-;; may fail to apply.
-(%user-type-proc-set! 'random-state-mt 'class-of )
-
-;; source
-
-(define-class () ())
-
-(push! (cons #:mt (lambda () (make
- #:algorithm 'mt
- #:state (%make-random-state-mt))))
- *prng-algorithms*)
-
-;; this is a random-source -- define the predicate!
-(define-method random-source? ((s )) #t)
-
-
-(define-method random-source-make-integers((s ))
- (let ((state (%random-source-state-ref s)))
- (lambda (n)
- (%random-integer-from-source-mt state n))))
-
-(define-method random-source-make-reals ((s ))
- (let ((state (%random-source-state-ref s)))
- (lambda ()
- (%random-real-from-source-mt state))))
-
-;; The following procedure is correct, but can probably be optimized,
-;; or maybe re-written in C.
-(define-method random-source-make-reals ((s )
- (unit ))
- (when (<= unit 0)
- (error "unit parameter ~S <= 0" unit))
- (when (>= unit 1)
- (error "unit parameter ~S >= 0" unit))
-
- ;; 1/unit is the number of slots of size "unit" that we can fit in
- ;; the [0,1] interval.
- ;;
- ;; rr is a random number in (0,1) -- and it will fall into *some* slot.
- ;; we find which one ('chosen-slot'), and then find the equivalent number
- ;; in the *first* slot ('quantum').
- ;; Then, the closure we return just calculates a slot and returns
- ;; slot * quantum.
- ;;
- ;; This way, the first number is (pseudo-)random, and the others are
- ;; spaced by exactly 'unit'.
- ;;
- ;; NOTE: we cannot use fixnum procedures here.
- ;;
- ;; CAVEAT: this works perfectly for rationals, but when choosing
- ;; floating-point numbers there will be a limit to the available precision
- ;; and the "random" numbers will always be zero.
- (let ((slots (inexact->exact (floor (/ 1 unit))))
- (rr ((random-source-make-reals s))))
- ;; The SRFI says the type of unit determines the type of the answer, so
- ;; we check if converting to rational is necessary:
- (let ((r (if (rational? unit)
- (inexact->exact rr)
- rr)))
- (let* ((chosen-slot (floor (/ r unit)))
- (quantum (- r (* unit chosen-slot))))
- ;; Each call to the returned procedure will just pick a slot and
- ;; return the representant of 'quantum' in that slot:
- (lambda ()
- (* quantum (+ 1 ((random-source-make-integers s) slots))))))))
-
-(define-method random-source-state-ref ((s ))
- (%random-state-copy-mt (%random-source-state-ref s)))
-
-(define-method random-source-state-set! ((src )
- (st ))
- (%random-source-state-set! src (%random-state-copy-mt st)))
-
-(define-method random-source-randomize! ((src ))
- (%random-source-randomize-mt! (%random-source-state-ref src)))
-
-(define (mix i j)
- ;;(let ((K #x1000000000000000)) ;; 2^63
- (let ((K 4611686018427387904)) ;; 2^63
- ;; Adapted from Gauche
- (define (interleave-i i j lis)
- (if (zero? i)
- (if (zero? j) lis (interleave-j 0 j (cons 0 lis)))
- (let ((q (quotient i K))
- (r (remainder i K)))
- (interleave-j q j (cons r lis)))))
-
- (define (interleave-j i j lis)
- (if (zero? j)
- (if (zero? i) lis (interleave-i i 0 (cons 0 lis)))
- (let ((q (quotient j K))
- (r (remainder j K)))
- (interleave-i i q (cons r lis)))))
-
- (interleave-i i j '(4611686018427387903)))) ;; 2^63 - 1
-
-(define-method random-source-pseudo-randomize! ((src )
- (i )
- (j ))
- (when (negative? i) (error "parameter i = ~S cannot be negative" i))
- (when (negative? j) (error "parameter j = ~S cannot be negative" j))
- ;; %random-source-pseudo-randomize-mt! takes a state and a
- ;; *vector containing fixnums only*
- (%random-source-pseudo-randomize-mt! (%random-source-state-ref src)
- (list->vector (mix (+ 1 i) (+ 1 j)))))
-
-
-;;;
-;;; DEFAULT RANDOM SOURCE
-;;;
-
-(define default-random-source
- (make
- #:algorithm 'mt
- #:state (%make-random-state-mt)))
-
-
-;; assigning to default-random-source should not change these procedures
-(define (random-integer n) (%random-integer-from-source-mt
- (%random-source-state-ref default-random-source n)))
-(define (random-real) (%random-real-from-source-mt
- (%random-source-state-ref default-random-source)))
+(define-module (srfi/27)
+ (export random-integer random-real default-random-source
+ make-random-source random-source?
+ random-source-state-ref random-source-state-set!
+ random-source-randomize! random-source-pseudo-randomize!
+ random-source-make-integers random-source-make-reals
+ random-source-make-reals)
-;;;
-;;; END OF SRFI-27 CODE
-;;;
-(provide "srfi/27")
+(define mrg32k3a-m1 #f) ; will be redefined later
+(define mrg32k3a-m2 #f) ; ditto
+(define %random-source? #f)
#|
* Return a real number |r| such that |0 < r < 1|.
* Subsequent results of this procedure appear to be independent uniformly
* distributed. This function is equivalent to the eponym
- * function of {{link-srfi 27}}.
+ * function of SRFI-27 (see ,(link-srfi 27) definition for more details).
doc>
|#
-;; These two procedures were broken due to autoloads, so we force their definition here
+;;; ======================================================================
+;;;
+;;; Low Level representation
+;;;
+;;; ======================================================================
+(define-class ()
+ ((state-ref :getter %random-source-state-ref)
+ (state-set! :getter %random-source-state-set!)
+ (randomize! :getter %random-source-randomize!)
+ (pseudo-randomize! :getter %random-source-pseudo-randomize!)
+ (make-integers :getter %random-source-make-integers)
+ (make-reals :getter %random-source-make-reals)))
+
+(define (%random-source-make state-ref state-set! randomize! pseudo-randomize!
+ make-integers make-reals)
+ (let ((res (make )))
+ (slot-set! res 'state-ref state-ref)
+ (slot-set! res 'state-set! state-set!)
+ (slot-set! res 'randomize! randomize!)
+ (slot-set! res 'pseudo-randomize! pseudo-randomize!)
+ (slot-set! res 'make-integers make-integers)
+ (slot-set! res 'make-reals make-reals)
+ res))
-(define-module STklos
- (import (srfi 27))
+(define-method %random-source? ((obj ))
+ #t)
- (define (random-integer n)
- ((in-module srfi/27 %random-integer-from-source-mt)
- ((in-module srfi/27 %random-source-state-ref) default-random-source) n))
+(define-method %random-source? (x139) #f)
- (define (random-real)
- ((in-module srfi/27 %random-real-from-source-mt)
- ((in-module srfi/27 %random-source-state-ref) default-random-source))))
+(define %random-source-current-time current-seconds)
+;;; ======================================================================
+;;;
+;;; Bottom half
+;;;
+;;; ======================================================================
+(define (mrg32k3a-random-m1 state)
+ (let ((x11 (vector-ref state 0))
+ (x12 (vector-ref state 1))
+ (x13 (vector-ref state 2))
+ (x21 (vector-ref state 3))
+ (x22 (vector-ref state 4))
+ (x23 (vector-ref state 5)))
+ (let ((x10 (modulo (- (* 1403580 x12) (* 810728 x13)) 4294967087))
+ (x20 (modulo (- (* 527612 x21) (* 1370589 x23)) 4294944443)))
+ (vector-set! state 0 x10)
+ (vector-set! state 1 x11)
+ (vector-set! state 2 x12)
+ (vector-set! state 3 x20)
+ (vector-set! state 4 x21)
+ (vector-set! state 5 x22)
+ (modulo (- x10 x20) 4294967087))))
+
+; interface to the generic parts of the generator
+
+(define (mrg32k3a-pack-state unpacked-state)
+ unpacked-state)
+
+(define (mrg32k3a-unpack-state state)
+ state)
+
+(define (mrg32k3a-random-range) ; m1
+ 4294967087)
+
+(define (mrg32k3a-random-integer state range) ; rejection method
+ (let* ((q (quotient 4294967087 range))
+ (qn (* q range)))
+ (do ((x (mrg32k3a-random-m1 state) (mrg32k3a-random-m1 state)))
+ ((< x qn) (quotient x q)))))
+
+(define (mrg32k3a-random-real state) ; normalization is 1/(m1+1)
+ (* 0.0000000002328306549295728 (+ 1.0 (mrg32k3a-random-m1 state))))
+
+;;; ======================================================================
+;;;
+;;; Top half
+;;;
+;;; ======================================================================
+
+
+; GENERIC PART OF MRG32k3a-GENERATOR FOR SRFI-27
+; ==============================================
+;
+; Sebastian.Egner@philips.com, 2002.
+;
+; This is the generic R5RS-part of the implementation of the MRG32k3a
+; generator to be used in SRFI-27. It is based on a separate implementation
+; of the core generator (presumably in native code) and on code to
+; provide essential functionality not available in R5RS (see below).
+;
+; compliance:
+; Scheme R5RS with integer covering at least {-2^53..2^53-1}.
+; In addition,
+; SRFI-23: error
+;
+; history of this file:
+; SE, 22-Mar-2002: refactored from earlier versions
+; SE, 25-Mar-2002: pack/unpack need not allocate
+; SE, 27-Mar-2002: changed interface to core generator
+; SE, 10-Apr-2002: updated spec of mrg32k3a-random-integer
+
+; Generator
+; =========
+;
+; Pierre L'Ecuyer's MRG32k3a generator is a Combined Multiple Recursive
+; Generator. It produces the sequence {(x[1,n] - x[2,n]) mod m1 : n}
+; defined by the two recursive generators
+;
+; x[1,n] = ( a12 x[1,n-2] + a13 x[1,n-3]) mod m1,
+; x[2,n] = (a21 x[2,n-1] + a23 x[2,n-3]) mod m2,
+;
+; where the constants are
+; m1 = 4294967087 = 2^32 - 209 modulus of 1st component
+; m2 = 4294944443 = 2^32 - 22853 modulus of 2nd component
+; a12 = 1403580 recursion coefficients
+; a13 = -810728
+; a21 = 527612
+; a23 = -1370589
+;
+; The generator passes all tests of G. Marsaglia's Diehard testsuite.
+; Its period is (m1^3 - 1)(m2^3 - 1)/2 which is nearly 2^191.
+; L'Ecuyer reports: "This generator is well-behaved in all dimensions
+; up to at least 45: ..." [with respect to the spectral test, SE].
+;
+; The period is maximal for all values of the seed as long as the
+; state of both recursive generators is not entirely zero.
+;
+; As the successor state is a linear combination of previous
+; states, it is possible to advance the generator by more than one
+; iteration by applying a linear transformation. The following
+; publication provides detailed information on how to do that:
+;
+; [1] P. L'Ecuyer, R. Simard, E. J. Chen, W. D. Kelton:
+; An Object-Oriented Random-Number Package With Many Long
+; Streams and Substreams. 2001.
+; To appear in Operations Research.
+;
+; Arithmetics
+; ===========
+;
+; The MRG32k3a generator produces values in {0..2^32-209-1}. All
+; subexpressions of the actual generator fit into {-2^53..2^53-1}.
+; The code below assumes that Scheme's "integer" covers this range.
+; In addition, it is assumed that floating point literals can be
+; read and there is some arithmetics with inexact numbers.
+;
+; However, for advancing the state of the generator by more than
+; one step at a time, the full range {0..2^32-209-1} is needed.
+
+
+; Required: Backbone Generator
+; ============================
+;
+; At this point in the code, the following procedures are assumed
+; to be defined to execute the core generator:
+;
+; (mrg32k3a-pack-state unpacked-state) -> packed-state
+; (mrg32k3a-unpack-state packed-state) -> unpacked-state
+; pack/unpack a state of the generator. The core generator works
+; on packed states, passed as an explicit argument, only. This
+; allows native code implementations to store their state in a
+; suitable form. Unpacked states are #(x10 x11 x12 x20 x21 x22)
+; with integer x_ij. Pack/unpack need not allocate new objects
+; in case packed and unpacked states are identical.
+;
+; (mrg32k3a-random-range) -> m-max
+; (mrg32k3a-random-integer packed-state range) -> x in {0..range-1}
+; advance the state of the generator and return the next random
+; range-limited integer.
+; Note that the state is not necessarily advanced by just one
+; step because we use the rejection method to avoid any problems
+; with distribution anomalies.
+; The range argument must be an exact integer in {1..m-max}.
+; It can be assumed that range is a fixnum if the Scheme system
+; has such a number representation.
+;
+; (mrg32k3a-random-real packed-state) -> x in (0,1)
+; advance the state of the generator and return the next random
+; real number between zero and one (both excluded). The type of
+; the result should be a flonum if possible.
+
+; Required: Record Data Type
+; ==========================
+;
+; At this point in the code, the following procedures are assumed
+; to be defined to create and access a new record data type:
+;
+; (%random-source-make a0 a1 a2 a3 a4 a5) -> s
+; constructs a new random source object s consisting of the
+; objects a0 .. a5 in this order.
+;
+; (%random-source? obj) -> bool
+; tests if a Scheme object is a %random-source.
+;
+; (%random-source-state-ref s) -> a0
+; (%random-source-state-set! s) -> a1
+; (%random-source-randomize! s) -> a2
+; (%random-source-pseudo-randomize! s) -> a3
+; (%random-source-make-integers s) -> a4
+; (%random-source-make-reals s) -> a5
+; retrieve the values in the fields of the object s.
+
+; Required: Current Time as an Integer
+; ====================================
+;
+; At this point in the code, the following procedure is assumed
+; to be defined to obtain a value that is likely to be different
+; for each invokation of the Scheme system:
+;
+; (%random-source-current-time) -> x
+; an integer that depends on the system clock. It is desired
+; that the integer changes as fast as possible.
+
+
+; Accessing the State
+; ===================
+
+(define (mrg32k3a-state-ref packed-state)
+ (cons 'lecuyer-mrg32k3a
+ (vector->list (mrg32k3a-unpack-state packed-state))))
+
+(define (mrg32k3a-state-set external-state)
+
+ (define (check-value x m)
+ (if (and (integer? x)
+ (exact? x)
+ (<= 0 x (- m 1)))
+ #t
+ (error "illegal value" x)))
+
+ (if (and (list? external-state)
+ (= (length external-state) 7)
+ (eq? (car external-state) 'lecuyer-mrg32k3a))
+ (let ((s (cdr external-state)))
+ (check-value (list-ref s 0) mrg32k3a-m1)
+ (check-value (list-ref s 1) mrg32k3a-m1)
+ (check-value (list-ref s 2) mrg32k3a-m1)
+ (check-value (list-ref s 3) mrg32k3a-m2)
+ (check-value (list-ref s 4) mrg32k3a-m2)
+ (check-value (list-ref s 5) mrg32k3a-m2)
+ (if (or (zero? (+ (list-ref s 0) (list-ref s 1) (list-ref s 2)))
+ (zero? (+ (list-ref s 3) (list-ref s 4) (list-ref s 5))))
+ (error "illegal degenerate state" external-state))
+ (mrg32k3a-pack-state (list->vector s)))
+ (error "malformed state" external-state)))
+
+
+; Pseudo-Randomization
+; ====================
+;
+; Reference [1] above shows how to obtain many long streams and
+; substream from the backbone generator.
+;
+; The idea is that the generator is a linear operation on the state.
+; Hence, we can express this operation as a 3x3-matrix acting on the
+; three most recent states. Raising the matrix to the k-th power, we
+; obtain the operation to advance the state by k steps at once. The
+; virtual streams and substreams are now simply parts of the entire
+; periodic sequence (which has period around 2^191).
+;
+; For the implementation it is necessary to compute with matrices in
+; the ring (Z/(m1*m1)*Z)^(3x3). By the Chinese-Remainder Theorem, this
+; is isomorphic to ((Z/m1*Z) x (Z/m2*Z))^(3x3). We represent such a pair
+; of matrices
+; [ [[x00 x01 x02],
+; [x10 x11 x12],
+; [x20 x21 x22]], mod m1
+; [[y00 y01 y02],
+; [y10 y11 y12],
+; [y20 y21 y22]] mod m2]
+; as a vector of length 18 of the integers as writen above:
+; #(x00 x01 x02 x10 x11 x12 x20 x21 x22
+; y00 y01 y02 y10 y11 y12 y20 y21 y22)
+;
+; As the implementation should only use the range {-2^53..2^53-1}, the
+; fundamental operation (x*y) mod m, where x, y, m are nearly 2^32,
+; is computed by breaking up x and y as x = x1*w + x0 and y = y1*w + y0
+; where w = 2^16. In this case, all operations fit the range because
+; w^2 mod m is a small number. If proper multiprecision integers are
+; available this is not necessary, but pseudo-randomize! is an expected
+; to be called only occasionally so we do not provide this implementation.
+
+(define mrg32k3a-m1 4294967087) ; modulus of component 1
+(define mrg32k3a-m2 4294944443) ; modulus of component 2
+
+(define mrg32k3a-initial-state ; 0 3 6 9 12 15 of A^16, see below
+ '#( 1062452522
+ 2961816100
+ 342112271
+ 2854655037
+ 3321940838
+ 3542344109))
+
+(define mrg32k3a-generators #f) ; computed when needed
+
+(define (mrg32k3a-pseudo-randomize-state i j)
+
+ (define (product A B) ; A*B in ((Z/m1*Z) x (Z/m2*Z))^(3x3)
+
+ (define w 65536) ; wordsize to split {0..2^32-1}
+ (define w-sqr1 209) ; w^2 mod m1
+ (define w-sqr2 22853) ; w^2 mod m2
+
+ (define (lc i0 i1 i2 j0 j1 j2 m w-sqr) ; linear combination
+ (let ((a0h (quotient (vector-ref A i0) w))
+ (a0l (modulo (vector-ref A i0) w))
+ (a1h (quotient (vector-ref A i1) w))
+ (a1l (modulo (vector-ref A i1) w))
+ (a2h (quotient (vector-ref A i2) w))
+ (a2l (modulo (vector-ref A i2) w))
+ (b0h (quotient (vector-ref B j0) w))
+ (b0l (modulo (vector-ref B j0) w))
+ (b1h (quotient (vector-ref B j1) w))
+ (b1l (modulo (vector-ref B j1) w))
+ (b2h (quotient (vector-ref B j2) w))
+ (b2l (modulo (vector-ref B j2) w)))
+ (modulo
+ (+ (* (+ (* a0h b0h)
+ (* a1h b1h)
+ (* a2h b2h))
+ w-sqr)
+ (* (+ (* a0h b0l)
+ (* a0l b0h)
+ (* a1h b1l)
+ (* a1l b1h)
+ (* a2h b2l)
+ (* a2l b2h))
+ w)
+ (* a0l b0l)
+ (* a1l b1l)
+ (* a2l b2l))
+ m)))
+
+ (vector
+ (lc 0 1 2 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_00 mod m1
+ (lc 0 1 2 1 4 7 mrg32k3a-m1 w-sqr1) ; (A*B)_01
+ (lc 0 1 2 2 5 8 mrg32k3a-m1 w-sqr1)
+ (lc 3 4 5 0 3 6 mrg32k3a-m1 w-sqr1) ; (A*B)_10
+ (lc 3 4 5 1 4 7 mrg32k3a-m1 w-sqr1)
+ (lc 3 4 5 2 5 8 mrg32k3a-m1 w-sqr1)
+ (lc 6 7 8 0 3 6 mrg32k3a-m1 w-sqr1)
+ (lc 6 7 8 1 4 7 mrg32k3a-m1 w-sqr1)
+ (lc 6 7 8 2 5 8 mrg32k3a-m1 w-sqr1)
+ (lc 9 10 11 9 12 15 mrg32k3a-m2 w-sqr2) ; (A*B)_00 mod m2
+ (lc 9 10 11 10 13 16 mrg32k3a-m2 w-sqr2)
+ (lc 9 10 11 11 14 17 mrg32k3a-m2 w-sqr2)
+ (lc 12 13 14 9 12 15 mrg32k3a-m2 w-sqr2)
+ (lc 12 13 14 10 13 16 mrg32k3a-m2 w-sqr2)
+ (lc 12 13 14 11 14 17 mrg32k3a-m2 w-sqr2)
+ (lc 15 16 17 9 12 15 mrg32k3a-m2 w-sqr2)
+ (lc 15 16 17 10 13 16 mrg32k3a-m2 w-sqr2)
+ (lc 15 16 17 11 14 17 mrg32k3a-m2 w-sqr2)))
+
+ (define (power A e) ; A^e
+ (cond
+ ((zero? e)
+ '#(1 0 0 0 1 0 0 0 1 1 0 0 0 1 0 0 0 1))
+ ((= e 1)
+ A)
+ ((even? e)
+ (power (product A A) (quotient e 2)))
+ (else
+ (product (power A (- e 1)) A))))
+
+ (define (power-power A b) ; A^(2^b)
+ (if (zero? b)
+ A
+ (power-power (product A A) (- b 1))))
+
+ (define A ; the MRG32k3a recursion
+ '#( 0 1403580 4294156359
+ 1 0 0
+ 0 1 0
+ 527612 0 4293573854
+ 1 0 0
+ 0 1 0))
+
+ ; check arguments
+ (if (not (and (integer? i)
+ (exact? i)
+ (integer? j)
+ (exact? j)))
+ (error "i j must be exact integer" i j))
+
+ ; precompute A^(2^127) and A^(2^76) only once
+
+ (if (not mrg32k3a-generators)
+ (set! mrg32k3a-generators
+ (list (power-power A 127)
+ (power-power A 76)
+ (power A 16))))
+
+ ; compute M = A^(16 + i*2^127 + j*2^76)
+ (let ((M (product
+ (list-ref mrg32k3a-generators 2)
+ (product
+ (power (list-ref mrg32k3a-generators 0)
+ (modulo i (expt 2 28)))
+ (power (list-ref mrg32k3a-generators 1)
+ (modulo j (expt 2 28)))))))
+ (mrg32k3a-pack-state
+ (vector
+ (vector-ref M 0)
+ (vector-ref M 3)
+ (vector-ref M 6)
+ (vector-ref M 9)
+ (vector-ref M 12)
+ (vector-ref M 15)))))
+
+; True Randomization
+; ==================
+;
+; The value obtained from the system time is feed into a very
+; simple pseudo random number generator. This in turn is used
+; to obtain numbers to randomize the state of the MRG32k3a
+; generator, avoiding period degeneration.
+
+(define (mrg32k3a-randomize-state state)
+
+ ; G. Marsaglia's simple 16-bit generator with carry
+ (define m 65536)
+ (define x (modulo (%random-source-current-time) m))
+ (define (random-m)
+ (let ((y (modulo x m)))
+ (set! x (+ (* 30903 y) (quotient x m)))
+ y))
+ (define (random n) ; m < n < m^2
+ (modulo (+ (* (random-m) m) (random-m)) n))
+
+ ; modify the state
+ (let ((m1 mrg32k3a-m1)
+ (m2 mrg32k3a-m2)
+ (s (mrg32k3a-unpack-state state)))
+ (mrg32k3a-pack-state
+ (vector
+ (+ 1 (modulo (+ (vector-ref s 0) (random (- m1 1))) (- m1 1)))
+ (modulo (+ (vector-ref s 1) (random m1)) m1)
+ (modulo (+ (vector-ref s 2) (random m1)) m1)
+ (+ 1 (modulo (+ (vector-ref s 3) (random (- m2 1))) (- m2 1)))
+ (modulo (+ (vector-ref s 4) (random m2)) m2)
+ (modulo (+ (vector-ref s 5) (random m2)) m2)))))
+
+
+; Large Integers
+; ==============
+;
+; To produce large integer random deviates, for n > m-max, we first
+; construct large random numbers in the range {0..m-max^k-1} for some
+; k such that m-max^k >= n and then use the rejection method to choose
+; uniformly from the range {0..n-1}.
+
+(define mrg32k3a-m-max
+ (mrg32k3a-random-range))
+
+(define (mrg32k3a-random-power state k) ; n = m-max^k, k >= 1
+ (if (= k 1)
+ (mrg32k3a-random-integer state mrg32k3a-m-max)
+ (+ (* (mrg32k3a-random-power state (- k 1)) mrg32k3a-m-max)
+ (mrg32k3a-random-integer state mrg32k3a-m-max))))
+
+(define (mrg32k3a-random-large state n) ; n > m-max
+ (do ((k 2 (+ k 1))
+ (mk (* mrg32k3a-m-max mrg32k3a-m-max) (* mk mrg32k3a-m-max)))
+ ((>= mk n)
+ (let* ((mk-by-n (quotient mk n))
+ (a (* mk-by-n n)))
+ (do ((x (mrg32k3a-random-power state k)
+ (mrg32k3a-random-power state k)))
+ ((< x a) (quotient x mk-by-n)))))))
+
+
+; Multiple Precision Reals
+; ========================
+;
+; To produce multiple precision reals we produce a large integer value
+; and convert it into a real value. This value is then normalized.
+; The precision goal is unit <= 1/(m^k + 1), or 1/unit - 1 <= m^k.
+; If you know more about the floating point number types of the
+; Scheme system, this can be improved.
+
+(define (mrg32k3a-random-real-mp state unit)
+ (do ((k 1 (+ k 1))
+ (u (- (/ 1 unit) 1) (/ u mrg32k3a-m1)))
+ ((<= u 1)
+ (/ (exact->inexact (+ (mrg32k3a-random-power state k) 1))
+ (exact->inexact (+ (expt mrg32k3a-m-max k) 1))))))
+
+
+; Provide the Interface as Specified in the SRFI
+; ==============================================
+;
+; An object of type random-source is a record containing the procedures
+; as components. The actual state of the generator is stored in the
+; binding-time environment of make-random-source.
+
+(define (make-random-source)
+ (let ((state (mrg32k3a-pack-state ; make a new copy
+ (list->vector (vector->list mrg32k3a-initial-state)))))
+ (%random-source-make
+ (lambda ()
+ (mrg32k3a-state-ref state))
+ (lambda (new-state)
+ (set! state (mrg32k3a-state-set new-state)))
+ (lambda ()
+ (set! state (mrg32k3a-randomize-state state)))
+ (lambda (i j)
+ (set! state (mrg32k3a-pseudo-randomize-state i j)))
+ (lambda ()
+ (lambda (n)
+ (cond
+ ((not (and (integer? n) (exact? n) (positive? n)))
+ (error "range must be exact positive integer" n))
+ ((<= n mrg32k3a-m-max)
+ (mrg32k3a-random-integer state n))
+ (else
+ (mrg32k3a-random-large state n)))))
+ (lambda args
+ (cond
+ ((null? args)
+ (lambda ()
+ (mrg32k3a-random-real state)))
+ ((null? (cdr args))
+ (let ((unit (car args)))
+ (cond
+ ((not (and (real? unit) (< 0 unit 1)))
+ (error "unit must be real in (0,1)" unit))
+ ((<= (- (/ 1 unit) 1) mrg32k3a-m1)
+ (lambda ()
+ (mrg32k3a-random-real state)))
+ (else
+ (lambda ()
+ (mrg32k3a-random-real-mp state unit))))))
+ (else
+ (error "illegal arguments" args)))))))
+
+(define random-source?
+ %random-source?)
+
+(define (random-source-state-ref s)
+ ((%random-source-state-ref s)))
+
+(define (random-source-state-set! s state)
+ ((%random-source-state-set! s) state))
+
+(define (random-source-randomize! s)
+ ((%random-source-randomize! s)))
+
+(define (random-source-pseudo-randomize! s i j)
+ ((%random-source-pseudo-randomize! s) i j))
+
+; ---
+
+(define (random-source-make-integers s)
+ ((%random-source-make-integers s)))
+
+(define (random-source-make-reals s . unit)
+ (apply (%random-source-make-reals s) unit))
+
+; ---
+
+(define default-random-source
+ (make-random-source))
+
+(define random-integer
+ (random-source-make-integers default-random-source))
+
+(define random-real
+ (random-source-make-reals default-random-source))
+)
+
+
+;;;;;; ======================================================================
+;;(select-module STklos)
+;;(import RANDOM-MODULE)
+;;
+;;;; define the autoloads in case this file is auto-loaded
+;;(define random-integer (in-module RANDOM-MODULE random-integer))
+;;(define random-real (in-module RANDOM-MODULE random-real))
+
+(provide "srfi/27")
diff --git a/lib/srfi/Makefile.am b/lib/srfi/Makefile.am
index ea2ac15e9..295684fd2 100644
--- a/lib/srfi/Makefile.am
+++ b/lib/srfi/Makefile.am
@@ -53,6 +53,7 @@ SRC_STK = 1.stk \
22.stk \
23.stk \
26.stk \
+ 27.stk \
28.stk \
29.stk \
31.stk \
@@ -165,6 +166,7 @@ SRC_OSTK = 1.ostk \
22.ostk \
23.ostk \
26.ostk \
+ 27.ostk \
28.ostk \
29.ostk \
31.ostk \
@@ -261,9 +263,9 @@ SRC_OSTK = 1.ostk \
#
# SRFIs written in C and Scheme
#
-SRC_C = 25.c 27.c 170.c 175.c 238.c
-SRC_C_STK = 25.stk 27.stk 170.stk 175.stk 238.stk
-SRC_SHOBJ = 25.$(SO) 27.$(SO) 170.$(SO) 175.$(SO) 238.$(SO)
+SRC_C = 25.c 170.c 175.c 238.c
+SRC_C_STK = 25.stk 170.stk 175.stk 238.stk
+SRC_SHOBJ = 25.$(SO) 170.$(SO) 175.$(SO) 238.$(SO)
srfi_OBJS = $(SRC_OSTK) $(SRC_SHOBJ)
diff --git a/lib/srfi/Makefile.in b/lib/srfi/Makefile.in
index 8d25d3f8a..f7dcd4443 100644
--- a/lib/srfi/Makefile.in
+++ b/lib/srfi/Makefile.in
@@ -418,6 +418,7 @@ SRC_STK = 1.stk \
22.stk \
23.stk \
26.stk \
+ 27.stk \
28.stk \
29.stk \
31.stk \
@@ -530,6 +531,7 @@ SRC_OSTK = 1.ostk \
22.ostk \
23.ostk \
26.ostk \
+ 27.ostk \
28.ostk \
29.ostk \
31.ostk \
@@ -626,9 +628,9 @@ SRC_OSTK = 1.ostk \
#
# SRFIs written in C and Scheme
#
-SRC_C = 25.c 27.c 170.c 175.c 238.c
-SRC_C_STK = 25.stk 27.stk 170.stk 175.stk 238.stk
-SRC_SHOBJ = 25.$(SO) 27.$(SO) 170.$(SO) 175.$(SO) 238.$(SO)
+SRC_C = 25.c 170.c 175.c 238.c
+SRC_C_STK = 25.stk 170.stk 175.stk 238.stk
+SRC_SHOBJ = 25.$(SO) 170.$(SO) 175.$(SO) 238.$(SO)
srfi_OBJS = $(SRC_OSTK) $(SRC_SHOBJ)
DOCDB = ../DOCDB
BASEDIR = ../..
diff --git a/lib/stklos/Makefile.am b/lib/stklos/Makefile.am
index ce1fb9c28..a3bb81867 100644
--- a/lib/stklos/Makefile.am
+++ b/lib/stklos/Makefile.am
@@ -30,8 +30,8 @@ SO = @SH_SUFFIX@
#
# Libraries written in Scheme only
#
-SRC_STK = preproc.stk
-SRC_OSTK = preproc.ostk
+SRC_STK = help.stk preproc.stk
+SRC_OSTK = help.ostk preproc.ostk
#
# Libraries written in C and Scheme
diff --git a/lib/stklos/Makefile.in b/lib/stklos/Makefile.in
index 808076038..ee6fc990b 100644
--- a/lib/stklos/Makefile.in
+++ b/lib/stklos/Makefile.in
@@ -355,8 +355,8 @@ SO = @SH_SUFFIX@
#
# Libraries written in Scheme only
#
-SRC_STK = preproc.stk
-SRC_OSTK = preproc.ostk
+SRC_STK = help.stk preproc.stk
+SRC_OSTK = help.ostk preproc.ostk
#
# Libraries written in C and Scheme
diff --git a/lib/help.stk b/lib/stklos/help.stk
similarity index 67%
rename from lib/help.stk
rename to lib/stklos/help.stk
index eca52e433..1abc32710 100644
--- a/lib/help.stk
+++ b/lib/stklos/help.stk
@@ -27,6 +27,11 @@
;;;; Creation date: 20-Dec-2009 18:26 (eg)
;;;;
+
+(define-module (stklos help)
+ (import SCHEME)
+ (export help)
+
;; ----------------------------------------------------------------------
;; Database reading
;; ----------------------------------------------------------------------
@@ -99,8 +104,7 @@
"left undocumented. Furthermore, they can be changed without notice.\n"
"Please don't use them.\n"))
(else
- ;; no documentation
- #f))))
+ #f))))
(define-method find-documentation ((self ))
@@ -111,12 +115,19 @@
(find-documentation (string->symbol name)))))))
(define-method find-documentation ((self ))
- (or (generic-function-documentation self)
- (find-documentation (generic-function-name self))))
+ (generic-function-documentation self))
(define-method find-documentation ((self ))
(find-documentation (method-procedure self)))
+(define-method find-documentation ((self ))
+ (find-documentation (%syntax-expander self)))
+
+(define-method find-documentation ((self ))
+ (let ((name (%parameter-name self)))
+ (and (string? name)
+ (find-documentation (string->symbol name)))))
+
(define-method find-documentation (obj)
#f)
@@ -151,48 +162,94 @@
doc>
|#
-;; Returns the name of the object, if it is a procedure, or
-;; default if it has no name or if it is not a procedure.
-;; If default is ommited, it is taken to be obj itself.
-(define (%get-object-name obj . default)
- (let ((def (if (null? default)
- obj
- (car default))))
- (if (procedure? obj)
- (let* ((name (%procedure-name obj)))
- (if (string? name)
- (string->symbol name)
- def))
- def)))
+;; Returns the name of the object, if it is known or #f
+(define-generic object-name)
+
+(define-method object-name ((obj ))
+ (let ((name (%procedure-name obj)))
+ (if (string? name)
+ (string->symbol name)
+ obj)))
+
+(define-method object-name ((obj ))
+ ;; syntax has always a name
+ (string->symbol (%syntax-name obj)))
+
+(define-method object-name ((obj ))
+ (generic-function-name obj))
+
+(define-method object-name ((obj ))
+ (object-name (method-generic-function obj)))
+
+(define-method object-name ((obj ))
+ (let ((name (%parameter-name obj)))
+ (if (string? name)
+ (string->symbol name)
+ obj)))
+
+(define-method object-name (obj)
+ obj)
+
+
;; Returns the signature of an object in a human-friendly form.
;; (f x y), or
;; (_ x y) if it is unnamed.
-(define (%help-signature obj)
- (if (closure? obj) ;; procedures don't have formals available for now
- (let* ((sig (procedure-formals obj)))
- (if sig
- (cons (%get-object-name obj '_) sig)
- #f))
- #f))
+(define-generic object-signature)
+
+(define-method object-signature ((obj ))
+ (let ((sig (and (closure? obj) (procedure-formals obj))))
+ (and sig (cons (object-name obj) sig))))
+
+(define-method object-signature ((obj ))
+ (let ((sig (procedure-formals (%syntax-expander obj))))
+ (and sig (cons (object-name obj) sig))))
+
+(define-method object-signature ((obj ))
+ (let ((sig (procedure-formals (method-procedure obj))))
+ (and sig (cons (object-name obj) sig))))
+
+(define-method object-signature ((obj ))
+ #f)
+
+(define-method object-signature (obj)
+ #f)
+
+;; ======================================================================
+;; Help with a parameter
(define-method help (obj)
(let ((doc (find-documentation obj))
- (sig (%help-signature obj))
- (name (%get-object-name obj))
+ (sig (object-signature obj))
+ (name (object-name obj))
(pr (lambda (str)
(printf " ~a\n" (regexp-replace-all "\n" str "\n ")))))
- (if (or sig doc)
- (begin
- (display (ansi-color 'bold 'yellow (format #f "Help for ~a:" name) 'normal "\n"))
- (when sig
- (display (ansi-color 'bold "Signature:" 'normal (format #f "\n ~S\n" sig))))
- (when doc
- (display (ansi-color 'bold "Documentation:" 'normal "\n"))
- (pr doc)))
- (display (ansi-color 'bold 'yellow (format #f "No help for ~a" name) 'normal "\n")))))
+ (cond
+ ((or sig doc)
+ ;; Documentation or signature found
+ (display (ansi-color 'bold 'yellow (format #f "Help for ~a:" name) 'normal "\n"))
+ (when sig
+ (display (ansi-color 'bold "Signature:" 'normal (format #f "\n ~S\n" sig))))
+ (when doc
+ (display (ansi-color 'bold "Documentation:" 'normal "\n"))
+ (pr doc)))
+
+ ((symbol? obj)
+ ;; We have a symbol and no documentation in the database. Perhaps, it's a closure
+ ;; with embedded documentation sting. Look at symbol value.
+ (let ((val (symbol-value* obj (current-module) #f)))
+ (if val
+ (help val)
+ (display (ansi-color 'bold 'yellow
+ (format "No help for ~a" obj) 'normal "\n")))))
+ (else
+ ;; We have lost
+ (display (ansi-color 'bold 'yellow (format #f "No help for ~a" name)
+ 'normal "\n"))))))
+;; ======================================================================
+;; Help without parameter
(define-method help ()
;; Interactive help
(display (do-color (get-repl-color :help)
@@ -205,14 +262,15 @@ doc>
(color (get-repl-color :error)))
(unless (eof-object? name)
(if (symbol? name)
- (let ((val (symbol-value* name (current-module) #f)))
- (if val
- (let ((sig (%help-signature val)))
- (when sig (printf "Signature: ~a\n" sig))
- (display (find-documentation val)))
- (display (do-color color (format "Symbol ~S is unbound\n" name)))))
+ (help name)
(display (do-color color "help only accepts symbols.\n")))
(Loop prompt))))
(display "done.\n"))
-(provide "help")
+) ;; End of module (stklos library)
+
+(select-module STklos)
+(import (stklos help))
+
+
+(provide "stklos/help")
diff --git a/lib/stklos/preproc.stk b/lib/stklos/preproc.stk
index df437002f..708791e04 100644
--- a/lib/stklos/preproc.stk
+++ b/lib/stklos/preproc.stk
@@ -42,7 +42,7 @@
(define-module stklos/preproc
(import (stklos preproc env))
(export stklos-pp-version verbosity parse-metadata process-file process-string
- translate)
+ translate document-value)
(define *printing* #t)
(define *print-stack* '())
@@ -122,6 +122,13 @@
(die (format "bad command call ~s" expr))))))
;;;;
+ ;;;; document-value
+ ;;;;
+ (define (document-value symbol . default)
+ (apply symbol-value symbol (find-module 'stklos/preproc/env) default))
+
+
+ ;;;;
;;;; parse-metadata
;;;;
(define (parse-metadata port :optional (test-end-markup? #t))
@@ -245,8 +252,9 @@
(set! ch (read-char port)))
(if (eof-object? ch)
- (unless (null? *print-stack*)
- (error "unclosed if/else")) ;; FIXME: add opening line
+ 'nothing
+ ;;(unless (null? *print-stack*)
+ ;; (error "unclosed if/else")) ;; FIXME: add opening line and FILE
(let ((val (cond
((eq? prev #\\)
ch)
diff --git a/lib/thread.stk b/lib/thread.stk
index e453c2159..87d176c6f 100644
--- a/lib/thread.stk
+++ b/lib/thread.stk
@@ -116,7 +116,7 @@ doc>
* `#t`.
doc>
|#
-(define thread-handler-error-show (make-parameter #t))
+(define-parameter thread-handler-error-show #t)
(define (thread-sleep! timeout)
diff --git a/src/boot.c b/src/boot.c
index fd40c3635..da723aa78 100644
--- a/src/boot.c
+++ b/src/boot.c
@@ -6,7 +6,7 @@ This is a dump of the image in file /home/eg/Projects/STklos/lib/boot.img3
#include "stklos.h"
-char* STk_boot_consts = "#(current-input-port original-input-port #:aa caar #:ad cdar #:da cadr #:dd cddr #:aaa caaar #:aad cdaar #:ada cadar #:add cddar #:daa caadr #:dad cdadr #:dda caddr #:ddd cdddr #:aaaa caaaar #:aaad cdaaar #:aada cadaar #:aadd cddaar #:adaa caadar #:adad cdadar #:adda caddar #:addd cdddar #:daaa caaadr #:daad cdaadr #:dada cadadr #:dadd cddadr #:ddaa caaddr #:ddad cdaddr #:ddda cadddr #:dddd cddddr pair? car map apply map* cdr for-each* filter filter-map append append-map append! append-map! generic? parameter? %procedure-plist #:setter key-get setter \"no setter defined for ~S\" error key-set! %set-procedure-plist! set-car! set-cdr! vector-ref vector-set! string-ref string-set! slot-ref slot-set! struct-ref struct-set! \"\" string->symbol \"~a\" format string-append symbol-append make-parameter stklos-debug-level compiler-known-globals memq register-new-global! for-each register-new-globals! %modules-stack current-module %create-module %module-create %module-restore raise %module-handler current-error-port \"\\x1b;[33m\" display \"\\x1b;[0m\" newline %debug STklos find-module when (lambda args (if (<= (length args) 1) (syntax-error 'when \"bad syntax in ~S\" `(when ,@args)) `(if ,(car args) (begin ,@(cdr args))))) length \"bad syntax in ~S\" %syntax-error if begin stklos %make-syntax unless (lambda args (if (<= (length args) 1) (syntax-error 'unless \"bad syntax in ~S\" `(unless ,@args)) `(if (not ,(car args)) (begin ,@(cdr args))))) \"bad syntax in ~S\" not set! (lambda args `(%%set! ,@args)) %%set! %claim-error (lambda (owner . body) (let ((x (gensym))) `(with-handler (lambda (,x) (error ,owner (condition-ref ,x 'message))) ,@body))) gensym with-handler lambda condition-ref quote message syntax-error (lambda args (if (zero? (length args)) (error 'syntax-error \"needs at least one argument\") `(%syntax-error ,@args))) zero? \"needs at least one argument\" define-syntax (lambda (macro-name syn-rules) (if (or (not (pair? syn-rules)) (not (eq? (car syn-rules) 'syntax-rules))) (error 'define-syntax \"in `~S', bad syntax-rules ~S\" macro-name syn-rules) (let ((ellipsis '...)) (when (or (symbol? (cadr syn-rules)) (keyword? (cadr syn-rules))) (set! ellipsis (cadr syn-rules)) (set! syn-rules (cdr syn-rules))) (let ((keywords (cons macro-name (cadr syn-rules))) (clauses (cddr syn-rules)) (find-clause (symbol-value 'find-clause (find-module 'MBE)))) `(define-macro (,macro-name . args) (%find-macro-clause ',macro-name args ',keywords ',clauses ',ellipsis)))))) syntax-rules \"in `~S', bad syntax-rules ~S\" ... symbol? keyword? find-clause MBE symbol-value define-macro args %find-macro-clause module-symbols library? module-symbols* module? %module-exports module-exports select-module (lambda (name) (let* ((compfile (in-module STKLOS-COMPILER *compiling-file*)) (mod (find-module name #f)) (newmod (or mod (if compfile (%module-create name) (error 'select-module \"module ~s does not exists\" name))))) (when (and mod (not (eq? name 'STklos))) (register-new-globals! (module-symbols mod))) `(begin (%%set-current-module (find-module ',name)) (when-compile (compiler-current-module ,newmod))))) symbol-value* *compiling-file* STKLOS-COMPILER \"module ~s does not exists\" %%set-current-module when-compile compiler-current-module define-module (lambda (name . body) (let ((oldmod (compiler-current-module)) (newmod (or (find-module name #f) (%module-create name)))) `(with-handler %module-handler (%%set-current-module (%module-create ',name)) (%%when-compile (compiler-current-module ,newmod)) ,@body (%%when-compile (compiler-current-module ,oldmod)) (%%set-current-module ((%%in-scheme '%module-restore))) (values (void) ',name)))) %%when-compile %%in-scheme values void list? only every import \"bad list of symbols ~s in only clause\" #:only \"bad only clause ~s\" except \"bad list of symbols ~s in except clause\" #:except \"bad except clause ~s\" prefix #:prefix \"bad prefix clause ~s\" rename \"bad list of associations ~s in rename clause\" #:rename \"bad rename clause ~s\" %normalize-library-name \"bad import set ~s\" %parse-imports %find-instanciated-module symbol->string require/provide \"module/library ~s does not exist\" %symbol->library-name \"symbol ~s is not in the import set\" filter! remove list-copy absent %syntax? %symbol-link reverse module-name module-imports %module-imports-set! %do-imports (lambda modules (let ((imp (%parse-imports modules))) (for-each (lambda (x) (%grab-file-information (symbol->string (car x)))) imp) (%do-imports (compiler-current-module) (list-copy imp) #t) `(%do-imports (current-module) (list-copy ',imp) #f))) %grab-file-information %%import reverse! %do-exports export \"bad renaming clause ~S\" \"bad exportation `~S'\" %parse-exports assq \"exported symbol ~s was previously renamed as ~S\" %module-exports-set! (lambda symbols (let ((s (%parse-exports symbols))) `(%do-exports (current-module) ',s))) export-syntax (lambda arg `(%%publish-syntax ,@arg)) %%publish-syntax in-module (lambda (mod symb . default) `(apply symbol-value* ',symb (find-module ',mod) ',default)) all-modules module-list %populate-scheme-module SCHEME ((SCHEME)) ((eval . eval) (disassemble . disassemble) (disassemble-expr . disassemble-expr) (%compiler-set-flags . %compiler-set-flags) (%grab-file-information . %grab-file-information) (%compiler-new-label . %compiler-new-label) (%macro-expand . %macro-expand) (compiler-current-module . compiler-current-module) (when-compile . when-compile) (when-load-and-compile . when-load-and-compile) (%syntax-error . %syntax-error) (%compile-time-define . %compile-time-define)) *compiler-port* + - * / fx+ fx- fx* fxquotient = < <= > >= fx=? fx fx<=? fx>? fx>=? fx= fx< fx<= fx> fx>= cons null? list eq? eqv? equal? %cxr list-ref *inline-table* *inline-symbols* (%set-current-module %%set-current-module %%execute %%execute-handler) *always-inlined* *code-instr* *code-constants* *code-labels* integer? label? NOP this-instr next-instr this-arg1 this-arg2 next-arg1 next-arg2 GOTO RETURN PUSH (IM-FALSE IM-TRUE IM-NIL IM-MINUS1 IM-ZERO IM-ONE IM-VOID) IM-FALSE FALSE-PUSH IM-TRUE TRUE-PUSH IM-NIL NIL-PUSH IM-MINUS1 MINUS1-PUSH IM-ZERO ZERO-PUSH IM-ONE ONE-PUSH IM-VOID VOID-PUSH SMALL-INT INT-PUSH CONSTANT CONSTANT-PUSH DEEP-LOCAL-REF DEEP-LOC-REF-PUSH IN-NOT (IN-NUMEQ IN-NUMDIFF IN-FXEQ IN-FXDIFF IN-NUMLT IN-NUMGT IN-NUMLE IN-NUMGE IN-EQ IN-EQV IN-EQUAL) IN-NUMEQ IN-NUMDIFF IN-FXEQ IN-FXDIFF IN-NUMLT IN-NUMGE IN-NUMGT IN-NUMLE IN-EQ IN-NOT-EQ IN-EQV IN-NOT-EQV IN-EQUAL IN-NOT-EQUAL JUMP-FALSE (IN-NUMEQ IN-NUMLT IN-NUMGT IN-NUMLE IN-NUMGE IN-EQ IN-EQV IN-EQUAL IN-NOT) JUMP-NUMDIFF JUMP-NUMEQ JUMP-NUMGE JUMP-NUMGT JUMP-NUMLE JUMP-NUMLT JUMP-NOT-EQ JUMP-NOT-EQV JUMP-NOT-EQUAL JUMP-TRUE GLOBAL-REF GLOBAL-REF-PUSH PUSH-GLOBAL-REF INVOKE PUSH-GREF-INVOKE TAIL-INVOKE PUSH-GREF-TAIL-INV PREPARE-CALL PUSH-PREPARE-CALL GREF-INVOKE GREF-TAIL-INVOKE (LOCAL-REF0 LOCAL-REF1 LOCAL-REF2 LOCAL-REF3 LOCAL-REF4) LOCAL-REF0 LOCAL-REF0-PUSH LOCAL-REF1 LOCAL-REF1-PUSH LOCAL-REF2 LOCAL-REF2-PUSH LOCAL-REF3 LOCAL-REF3-PUSH LOCAL-REF4 LOCAL-REF4-PUSH peephole ((NOP 0) (IM-FALSE 0) (IM-TRUE 0) (IM-NIL 0) (IM-MINUS1 0) (IM-ZERO 0) (IM-ONE 0) (IM-VOID 0) (SMALL-INT 1) (CONSTANT 1) (GLOBAL-REF 1) (UGLOBAL-REF 1) (LOCAL-REF0 0) (LOCAL-REF1 0) (LOCAL-REF2 0) (LOCAL-REF3 0) (LOCAL-REF4 0) (LOCAL-REF 1) (DEEP-LOCAL-REF 1) (GLOBAL-SET 1) (UGLOBAL-SET 1) (LOCAL-SET0 0) (LOCAL-SET1 0) (LOCAL-SET2 0) (LOCAL-SET3 0) (LOCAL-SET4 0) (LOCAL-SET 1) (DEEP-LOCAL-SET 1) (GOTO 1) (JUMP-FALSE 1) (JUMP-TRUE 1) (DEFINE-SYMBOL 1) (POP 0) (PUSH 0) (DBG-VM 1) (CREATE-CLOSURE 2) (RETURN 0) (PREPARE-CALL 0) (INVOKE 1) (TAIL-INVOKE 1) (ENTER-LET-STAR 1) (ENTER-LET 1) (ENTER-TAIL-LET-STAR 1) (ENTER-TAIL-LET 1) (LEAVE-LET 0) (PUSH-HANDLER 1) (POP-HANDLER 0) (END-OF-CODE 0) (IN-ADD2 0) (IN-SUB2 0) (IN-MUL2 0) (IN-DIV2 0) (IN-NUMEQ 0) (IN-NUMLT 0) (IN-NUMGT 0) (IN-NUMLE 0) (IN-NUMGE 0) (IN-INCR 0) (IN-DECR 0) (IN-CONS 0) (IN-NULLP 0) (IN-CAR 0) (IN-CDR 0) (IN-LIST 1) (IN-NOT 0) (IN-VREF 0) (IN-VSET 0) (IN-SREF 0) (IN-SSET 0) (IN-EQ 0) (IN-EQV 0) (IN-EQUAL 0) (IN-APPLY 2) (IN-CXR 1) (SET-CUR-MOD 0) (DOCSTRG 1) (PROCNAME 1) (FALSE-PUSH 0) (TRUE-PUSH 0) (NIL-PUSH 0) (MINUS1-PUSH 0) (ZERO-PUSH 0) (ONE-PUSH 0) (VOID-PUSH 0) (INT-PUSH 1) (CONSTANT-PUSH 1) (GREF-INVOKE 2) (UGREF-INVOKE 2) (IN-NUMDIFF 0) (IN-NOT-EQ 0) (IN-NOT-EQV 0) (IN-NOT-EQUAL 0) (JUMP-NUMDIFF 1) (JUMP-NUMEQ 1) (JUMP-NUMLT 1) (JUMP-NUMLE 1) (JUMP-NUMGT 1) (JUMP-NUMGE 1) (JUMP-NOT-EQ 1) (JUMP-NOT-EQV 1) (JUMP-NOT-EQUAL 1) (LOCAL-REF0-PUSH 0) (LOCAL-REF1-PUSH 0) (LOCAL-REF2-PUSH 0) (LOCAL-REF3-PUSH 0) (LOCAL-REF4-PUSH 0) (GLOBAL-REF-PUSH 1) (UGLOBAL-REF-PUSH 1) (GREF-TAIL-INVOKE 2) (UGREF-TAIL-INVOKE 2) (PUSH-PREPARE-CALL 0) (PUSH-GLOBAL-REF 1) (PUSH-UGLOBAL-REF 1) (PUSH-GREF-INVOKE 2) (PUSH-UGREF-INVOKE 2) (PUSH-GREF-TAIL-INV 2) (PUSH-UGREF-TAIL-INV 2) (DEEP-LOC-REF-PUSH 1) (UNUSED-3 0) (UNUSED-4 0) (UNUSED-5 0) (UNUSED-6 0) (UNUSED-7 0) (UNUSED-8 0) (UNUSED-9 0) (UNUSED-10 0) (UNUSED-11 0) (UNUSED-12 0) (UNUSED-13 0) (UNUSED-14 0) (UNUSED-15 0) (UNUSED-16 0) (UNUSED-17 0) (UNUSED-18 0) (UNUSED-19 0) (IN-SINT-ADD2 1) (IN-SINT-SUB2 1) (IN-SINT-MUL2 1) (IN-SINT-DIV2 1) (UNUSED-20 0) (UNUSED-21 0) (UNUSED-22 0) (UNUSED-23 0) (UNUSED-24 0) (UNUSED-25 0) (UNUSED-26 0) (UNUSED-27 0) (UNUSED-28 0) (CALL-LOCATION 1) (DEEP-LOC-REF-FAR 1) (DEEP-LOC-SET-FAR 1) (CREATE-CLOSURE-FAR 2) (PUSH-HANDLER-FAR 1) (IN-FXADD2 0) (IN-FXSUB2 0) (IN-FXMUL2 0) (IN-FXDIV2 0) (IN-SINT-FXADD2 1) (IN-SINT-FXSUB2 1) (IN-SINT-FXMUL2 1) (IN-SINT-FXDIV2 1) (IN-FXEQ 0) (IN-FXLT 0) (IN-FXGT 0) (IN-FXLE 0) (IN-FXGE 0) (IN-FXDIFF 0) (SOURCE 1) (FORMALS 1) (INSCHEME 0)) INSTRUCTION-SET \"non existent opcode ~S\" panic info-opcode (GOTO JUMP-FALSE JUMP-TRUE JUMP-NUMDIFF JUMP-NUMGE JUMP-NUMGT JUMP-NUMGE JUMP-NUMLT JUMP-NUMLE JUMP-NOT-EQ JUMP-NOT-EQV JUMP-NOT-EQUAL CREATE-CLOSURE CREATE-CLOSURE-FAR PUSH-HANDLER PUSH-HANDLER-FAR) use-address? string-upcase string-length #\\space make-string pretty-mnemonic \"Cannot decode ~S opcode\" find-instruction-infos CREATE-CLOSURE CREATE-CLOSURE-FAR PUSH-HANDLER PUSH-HANDLER-FAR \"No FAR version of instruction ~S\" find-far-codeop make-vector small-integer-constant? (CREATE-CLOSURE-FAR PUSH-HANDLER-FAR) memv fetch-constant \"Instr. using a big constant as 2nd operand ~S\" \"Instruction with more than 2 parameters ~S\" assemble \"~A~A~A\" quotient remainder \"\\t;; ==> ~A\" vector-length \"\\n~A: ~A\" \" ~A\" \" ~S ~S\" \"cannot disassemble instruction (~S)\" \"\\n~A:\\n\" disassemble-code current-output-port \"too many optional parameters: ~a\" %procedure-code disassemble \"cannot disassemble ~S (not a closure with bytecode)\" compile END-OF-CODE emit vector-copy \"\\nConstants:\\n\" fprintf \"~A: ~W\\n\" dynamic-wind disassemble-expr \"*** PANIC *** \" getcwd string-position substring %path-without-cwd \"\" \"~A: \" %epair? \"~A:~A: \" %epair-file %epair-line %port-file-fd \"~A:~A: \" port-file-name port-current-line \"\" \"~AError: ~A~A\\n\" compiler-error \"\" \"~A: \" \"~A:~A: \" \"\" \"~Awarning: ~A~A\\n\" \"**** Warning;\\n~A~A\\n\" compiler-warning unquote \"used outside of a quasiquote context\" unquote-splicing \"used outside of a quasiquote context\" string? \"bad parameters ~S\" \"bad parameters ~S\" *file-module-list* file-module-list-reset! add-file-module-list! %syntax-source file-module-list-expanders #:prepend G33 #:version version #:globals #:macros clock compiler:warn-use-undefined-postpone compile-file \"prepend should be a list: ~S\" %include-file \"#!/usr/bin/env stklos\\n\" \"; A -*- Scheme -*- generated file *DO NOT EDIT**\\n\" \"STklos ~S\\n\" compiler:show-assembly-code \"\\n#|\\n\" \"\\n~S\\n|#\\n\" \"#~S\\n\" %dump-code close-output-port compiler-show-undefined-symbols interactive-port? compiler:time-display \"Compilation time ~S ms\\n\" round exact dirname \"stk-tmp.\" make-path create-temp-file file-exists? delete-file rename-file call-with-values ((compile-file . compile-file)) ((compiler:time-display . compiler:time-display) (compiler:gen-line-number . compiler:gen-line-number) (compiler:warn-use-undefined . compiler:warn-use-undefined) (compiler:warn-use-undefined-postpone . compiler:warn-use-undefined-postpone) (compiler:show-assembly-code . compiler:show-assembly-code) (compiler:keep-formals . compiler:keep-formals) (compiler:keep-source . compiler:keep-source) (compiler:inline-common-functions . compiler:inline-common-functions) (compiler:unroll-iterations . compiler:unroll-iterations)) compiler:gen-line-number compiler:warn-use-undefined compiler:keep-formals compiler:keep-source fixnum? positive? compiler:unroll-iterations \"must be a positive fixnum. It was ~s\" \"Fatal error: ~a\\nABORT\\n\" condition-message eprintf emergency-exit (#\\+ #\\-) #\\+ char=? line-info time-display keep-formals compiler:generate-signature keep-source inline-usuals compiler:inline-common-functions show-instructions \"bad boolean flag ~s\" \"=\" string-split string->number unroll-iterations \"bad value for unroll-iteration ~s\" \"bad flag name ~s\" \"bad valued flag ~s\" \",\" %compiler-set-flags scope (locals mlocals parent) make-struct-type make-struct make-scope struct? struct-is-a? scope? scope-locals %fast-struct-ref scope-mlocals scope-parent %fast-struct-set! find-symbol-in-env \"***SCOPE*** ~S\\n\" \" ==> locals= ~S mlocals= ~S parent =~S\" %debug-scope find-syntax-in-env %macro-expand quasiquote %syntax-expander \"bad module parameter ~s\" new-label %compiler-new-label emit-label expt exact? compile-constant \"bad usage in ~S\" compile-quote *forward-globals* symbol-bound? known-var? \"reference to undefined symbol ~S\" compiler-warn-undef verify-global define define->lambda \"ill formed definition ~S\" \"bad definition\" DEFINE-SYMBOL \"bad variable name ~S\" \"internal define forbidden here ~S\" compile-define GLOBAL-SET LOCAL-SET0 LOCAL-SET1 LOCAL-SET2 LOCAL-SET3 LOCAL-SET4 LOCAL-REF LOCAL-SET DEEP-LOCAL-SET DEEP-LOC-REF-FAR DEEP-LOC-SET-FAR compile-access compile-reference \"~S is a bad symbol\" \"bad assignment syntax in ~S\" compile-set! \"bad syntax in ~S\" compile-if extended-lambda->lambda eval %symbol-define \"bad variable name ~S\" \"internal define-macro forbidden here ~S\" compile-define-macro compile-and compile-or compile-begin compute-arity extend-env extract-doc-and-name \"body is empty\" let compile-body DOCSTRG PROCNAME keyword->string FORMALS SOURCE compile-user-lambda ext-lambda-key-get and or 'lambda make-keyword \"too many optional parameters: ~a\" let* build-let* \"illegal ~a parameter: ~a\" \"optional\" \"keyword\" (#:optional #:key #:rest) \"duplicate parameter ~S\" \"bad class name ~S\" \"bad procedure parameter ~S\" last-pair #:rest #:optional #:key \"illegal lambda list ending with ~a\" \"rest parameter must be a single symbol\" parse-parameter-list rewrite-params-and-body method \"bad definition ~S\" compile-lambda compile-args compile-var-args CALL-LOCATION %maybe-generate-line-information generate-PREPARE-CALL compile-normal-call assoc can-be-inlined? \"1 argument required (~A provided)\" \"2 arguments required (~A provided)\" \"3 arguments required (~A provided)\" SET-CUR-MOD \"1 arg. only (~S)\" %%execute-handler EXEC-HANDLER number? IN-INCR IN-SINT-ADD2 IN-ADD2 \"needs at least one argument\" IN-SINT-SUB2 IN-DECR IN-SUB2 IN-SINT-MUL2 IN-MUL2 \"needs at least one argument\" IN-SINT-DIV2 IN-DIV2 (fx+ fx- fx* fxquotient) (fx+ fx*) IN-SINT-FXADD2 IN-SINT-FXMUL2 IN-SINT-FXSUB2 IN-SINT-FXDIV2 IN-FXADD2 IN-FXSUB2 IN-FXMUL2 IN-FXDIV2 (= < > <= >=) O \"needs at least one argument\" (fx=? fx fx>? fx<=? fx>=? fx= fx< fx> fx<= fx>=) \"needs at least one argument\" (fx=? fx=) (fx fx<) IN-FXLT (fx>? fx>) IN-FXGT (fx<=? fx<=) IN-FXLE (fx>=? fx>=) IN-FXGE IN-CONS IN-CAR IN-CDR IN-NULLP IN-LIST IN-VREF IN-VSET IN-SREF IN-SSET (caar cdar cadr cddr caaar cdaar cadar cddar caadr cdadr caddr cdddr caaaar cdaaar cadaar cddaar caadar cdadar caddar cdddar caaadr cdaadr cadadr cddadr caaddr cdaddr cadddr cddddr) string->list list->string string->keyword IN-CXR \"unimplemented inline primitive ~S\" compile-primitive-call negative? ENTER-TAIL-LET ENTER-LET LEAVE-LET \"bad number of parameters ~S\" compile-lambda-call |λ| compile-call \"duplicate binding ~S\" \"malformed binding ~S\" valid-let-bindings? letrec \"ill formed letrec ~S\" compile-letrec \"ill formed named let ~S\" compile-named-let \"ill formed let ~S\" compile-let \"ill formed let* ~S\" ENTER-TAIL-LET-STAR ENTER-LET-STAR compile-let* cond \"invalid clause ~S\" else \"else not in last clause ~S\" => rewrite-cond-clauses \"bad '=>' clause syntax ~S\" compile-cond ok case \"duplicate case value ~S in ~S\" \"ill formed case clause ~S\" \"invalid clause syntax in ~S\" \"ill formed else clause ~S\" \"ill formed clause ~S\" rewrite-case-clauses \"no key given\" compile-case do \"bad binding ~S\" rewrite-do \"bad syntax\" compile-do 'quasiquote backquotify 'unquote 'unquote-splicing vector? list->vector vector->list \"bad syntax\" compile-quasiquote POP-HANDLER \"bad syntax\" compile-with-handler open-input-file eof-object? %read close-port include \"bad include directive ~S\" compile-include include-ci \"bad include directive ~S\" read-case-sensitive compile-include-ci INSCHEME \"expected one argument\" compile-in-scheme %let-syntax \"ill formed %let-syntax ~S\" \"ill formed binding ~S\" compile-%let-syntax %file-information remove-file #:nature source data %library-prefix load-path find-path unknown find-file-information member import-file-information boolean? compile-require \"*** Exception on when-compile form of ~S\\n\" compile-when-compile (lambda body `(begin (%%when-compile ,@body) (void))) when-load-and-compile (lambda body `(begin (%%when-compile ,@body) ,@body (void))) %%label \"bad usage ~S\" compile-%%label %%goto \"bad usage ~S\" compile-%%goto compile-%%source-pos (lambda |λ|) (let %let) %%require %%include %%include-ci %%source-pos %execute %compile-time-define (lambda symbs `(when-compile ,@(map (lambda (x) `(define ,x #void)) symbs))) ((STKLOS-COMPILER)) ((with-input-from-file . with-input-from-file) (with-output-to-file . with-output-to-file) (with-error-to-file . with-error-to-file) (with-input-from-string . with-input-from-string) (with-output-to-string . with-output-to-string) (with-input-from-port . with-input-from-port) (with-output-to-port . with-output-to-port) (with-error-to-port . with-error-to-port) (%call-with . %call-with) (call-with-input-file . call-with-input-file) (call-with-output-file . call-with-output-file) (rationalize . rationalize) (call-with-values . call-with-values)) open-file &i/o-filename-error location \"cannot open file ~S\" backtrace %vm-backtrace filename make-condition %make-with-file with-input-from-file \"r\" with-output-to-file \"w\" with-error-to-file \"w\" open-input-string with-input-from-string open-output-string get-output-string with-output-to-string %make-with-port \"r\" with-input-from-port \"w\" with-output-to-port \"w\" with-error-to-port %call-with call-with-input-file open-output-file call-with-output-file rationalize \"bad rational ~S\" floor 0.0 rational? %call-for-values %use-utf8? string-blit! string-titlecase string-titlecase! \"bad string ~S\" \" \\t\\n\" %string-use-utf8? \"bad offset ~S\" string-mutable? \"changing the constant string ~S is not allowed\" \"bad starting index ~S\" \"bad ending index ~S\" char-alphabetic? char-upcase char-downcase \"bad starting index ~S\" \"bad ending index ~S\" ((call/cc . call/cc) (call-with-current-continuation . call-with-current-continuation) (dynamic-wind . dynamic-wind)) %make-continuation %fresh-continuation? %restore-continuation %call/cc call/cc %thread-dynwind-stack %thread-dynwind-stack-set! procedure? \"bad procedure ~S\" call-with-current-continuation ((define-struct . define-struct)) define-struct (lambda (name . slots) (define (compute-offset slot slots) (let ((sublist (memq slot slots))) (- (length slots) (length sublist)))) (let* ((pred (string->symbol (format \"~a?\" name))) (arg (gensym)) (val (gensym))) `(begin (define ,name (make-struct-type ',name #f ',slots)) (define (,(string->symbol (format \"make-~a\" name)) unquote arg) (apply make-struct ,name ,arg)) (define (,pred ,arg) (and (struct? ,arg) (struct-is-a? ,arg ,name))) ,@(map (lambda (x) (let ((fname (string->symbol (format \"~a-~a\" name x)))) `(define ,fname (lambda (,arg) (%fast-struct-ref ,arg ,name ',fname ,(compute-offset x slots)))))) slots) ,@(map (lambda (x) (let ((fname (string->symbol (format \"~a-~a\" name x)))) `(set! (setter ,fname) (lambda (,arg ,val) (%fast-struct-set! ,arg ,name ',fname ,(compute-offset x slots) ,val))))) slots) (values (void) ',name)))) \"~a?\" \"make-~a\" \"~a-~a\" \"~a-~a\" ((read-chars . read-chars) (read-chars! . read-chars!) (display-shared . display-shared) (gensym . gensym) (macro-expand . macro-expand) (macro-expand* . macro-expand*) (remove . remove) (remove! . remove!) (delete . delete) (delete! . delete!) (every . every) (any . any) (call-with-input-string . call-with-input-string) (call-with-output-string . call-with-output-string) (open-input-virtual . open-input-virtual) (open-output-virtual . open-output-virtual) (read-from-string . read-from-string) (eval-from-string . eval-from-string) (command-line . command-line) (program-name . program-name) (create-directories . create-directories) (ensure-directories-exist . ensure-directories-exist) (posix-error? . posix-error?) (posix-error-name . posix-error-name) (posix-error-message . posix-error-message) (posix-error-errno . posix-error-errno) (posix-error-procedure . posix-error-procedure) (posix-error-arguments . posix-error-arguments) (make-hash-table . make-hash-table) (hash-table->alist . hash-table->alist) (alist->hash-table . alist->hash-table) (hash-table-update! . hash-table-update!) (hash-table-update!/default . hash-table-update!/default) (hash-table-keys . hash-table-keys) (hash-table-values . hash-table-values) (hash-table-fold . hash-table-fold) (hash-table-merge! . hash-table-merge!) (hash-table-copy . hash-table-copy) (fluid-let . fluid-let) (time . time) (tagbody . tagbody) (dotimes . dotimes) (repeat . repeat) (while . while) (until . until) (call/ec . call/ec) (base64-encode-string . base64-encode-string) (base64-decode-string . base64-decode-string) (md5sum-file . md5sum-file) (ansi-color . ansi-color) (ansi-color-protect . ansi-color-protect) (do-color . do-color) (port->string . port->string) (port->sexp-list . port->sexp-list) (port->string-list . port->string-list) (print . print) (printerr . printerr) (eprintf . eprintf) (printf . printf) (fprintf . fprintf) (declare-new-error . declare-new-error) (exec . exec) (exec-list . exec-list) (apropos . apropos) (die . die) (decompose-file-name . decompose-file-name) (dirname . dirname) (basename . basename) (file-separator . file-separator) (make-path . make-path) (file-suffix . file-suffix) (file-prefix . file-prefix) (port-idle-register! . port-idle-register!) (port-idle-unregister! . port-idle-unregister!) (port-idle-reset! . port-idle-reset!) (chmod . chmod) (with-mutex . with-mutex) (error-object-location . error-object-location) (%push-id . %push-id) (%stable-version? . %stable-version?) (define-constant . define-constant) (void? . void?) (receive . receive) (case-lambda . case-lambda) (radians->degrees . radians->degrees) (degrees->radians . degrees->radians) (%define-condition-type-accessors . %define-condition-type-accessors) (message-condition? . message-condition?) (condition-message . condition-message) (serious-condition? . serious-condition?) (error? . error?) (error-message? . error-message?) (error-location . error-location) (error-message . error-message) (read-with-shared-structure . read-with-shared-structure) (read/ss . read/ss) (write-with-shared-structure . write-with-shared-structure) (write/ss . write/ss) (parameterize . parameterize) (require-extension . require-extension) (string->keyword . string->keyword) (get-environment-variable . get-environment-variable) (get-environment-variables . get-environment-variables) (implementation-name . implementation-name) (implementation-version . implementation-version) (cpu-architecture . cpu-architecture) (machine-name . machine-name) (os-name . os-name) (os-version . os-version) (fx-width . fx-width) (fx-greatest . fx-greatest) (fx-least . fx-least) (assume . assume) (version-alist . version-alist) (port-has-port-position? . port-has-port-position?) (port-position . port-position) (port-has-set-port-position!? . port-has-set-port-position!?) (set-port-position! . set-port-position!) (make-i/o-invalid-position-error . make-i/o-invalid-position-error) (i/o-invalid-position-error? . i/o-invalid-position-error?) (command-name . command-name) (command-args . command-args) (argc . argc) (script-file . script-file) (script-directory . script-directory) (make-nan . make-nan)) read-bytes read-chars read-bytes! read-chars! display-shared \"G\" \"bad gensym prefix ~S\" number->string string->uninterned-symbol macro-expand macro-expand* remove! delete delete! \"bad procedure\" any \"bad procedure\" call-with-input-string call-with-output-string #:read-char #:ready? #:eof? #:close vector %open-input-virtual open-input-virtual #:write-char #:write-string #:flush %open-output-virtual open-output-virtual read read-from-string eval-from-string *%system-state-plist* #:script-file \"\" \"\" \"\" #:program-name \"\" #:argv \"bad command line ~S\" command-line program-name file-is-directory? create-directories create-directory ensure-directories-exist condition? &posix-error condition-has-type? posix-error? \"expected a posix-error condition\" %posix-error-condition-ref errname posix-error-name r7rs-msg posix-error-message errno posix-error-errno posix-error-procedure r7rs-irritants posix-error-arguments hash-table-hash %make-hash-table make-hash-table hash-table-map hash-table->alist hash-table-exists? hash-table-set! alist->hash-table hash-table-ref hash-table-update! hash-table-ref/default hash-table-update!/default hash-table-keys hash-table-values hash-table-for-each hash-table-fold hash-table-merge! hash-table-equivalence-function hash-table-hash-function hash-table-copy fluid-let (lambda (bindings . body) (let* ((vars (map car bindings)) (vals (map cadr bindings)) (tmps (map (lambda (x) (gensym)) vars))) `(let ,(map list tmps vars) (dynamic-wind (lambda () ,@(map (lambda (x y) `(set! ,x ,y)) vars vals)) (lambda () ,@body) (lambda () ,@(map (lambda (x y) `(set! ,x ,y)) vars tmps)))))) time (lambda args (let ((tmp1 (gensym)) (tmp2 (gensym))) `(let* ((,tmp1 (clock)) (,tmp2 (begin ,@args))) (format (current-error-port) \"Elapsed time: ~S ms\\n\" (- (clock) ,tmp1)) ,tmp2))) \"Elapsed time: ~S ms\\n\" tagbody (lambda body (let ((tags (map (lambda (x) (cons x (%compiler-new-label))) (filter keyword? body)))) (define (replace code) (if (pair? code) (if (and (eq? (car code) '->) (= (length code) 2)) (let ((t (assq (cadr code) tags))) (if t `(%%goto ,(cdr t)) code)) (map replace code)) code)) (define (verify code) (if (pair? code) (cond ((and (eq? (car code) '->) (= (length code) 2)) (error 'tagbody \"destination label ~S not defined\\n\" (cadr code))) ((eq? (car code) 'tagbody) #void) (else (map verify code))))) (let ((new-body (map (lambda (x) (if (keyword? x) `(%%label ,(cdr (assq x tags))) (replace x))) body))) (verify new-body) `(begin ,@new-body)))) -> \"destination label ~S not defined\\n\" dotimes (lambda (bindings . body) (apply (lambda (var count . result) (let* ((result (if (null? result) (list '(void)) result)) (limit (if (number? count) count (gensym))) (head (if (number? count) '(begin) `(let ((,limit ,count))))) (plus (if (fixnum? count) 'fx+ '+)) (ge (if (fixnum? count) 'fx>= '>=))) `(,@head (do ((,var 0 (,plus ,var 1))) ((,ge ,var ,limit) ,@result) ,@body)))) bindings)) (void) (begin) repeat (lambda (count . body) (define (%repeat n body use-fx?) (let ((minus (if use-fx? 'fx- '-)) (gt (if use-fx? 'fx> '>))) `(tagbody #:top (when (,gt ,n 0) (set! ,n (,minus ,n 1)) ,@body (-> #:top))))) (define (%multiply-list L k) (cond ((fx=? k 0) '()) ((fx=? k 1) (list-copy L)) (else (append (list-copy L) (%multiply-list L (fx- k 1)))))) (let* ((it (compiler:unroll-iterations)) (inside (%multiply-list body it)) (c (gensym)) (q (gensym)) (r (gensym))) (if (fixnum? count) (if (and (= it 1) (positive? count)) `(let ((,c ,count)) ,(%repeat c body #t)) (let ((valq (quotient count it)) (valr (remainder count it))) `(begin ,(if (positive? valq) `(let ((,q ,valq)) ,(%repeat q inside #t)) `(void)) ,(if (positive? valr) `(let ((,r ,valr)) ,(%repeat r body #t)) `(void))))) (if (= it 1) `(let ((,c ,count)) ,(%repeat c body #f)) `(let* ((,c ,count) (,q (quotient ,c ,it)) (,r (remainder ,c ,it))) ,(%repeat q inside #f) ,(%repeat r body #f)))))) #:top while (lambda (test . body) `(tagbody #:top (when ,test (begin ,@body (-> #:top))))) until (lambda (test . body) `(tagbody #:top (unless ,test (begin ,@body (-> #:top))))) \"call/ec\" call/ec base64-encode-string base64-decode-string \"bad string ~s\" base64-encode base64-decode \"r\" md5sum close-input-port \"cannot read file ~s\" md5sum-file ansi-color ansi-color-protect \"\\x1b;[\" \"m\" ((normal . \"0\") (bold . \"1\") (no-bold . \"21\") (italic . \"2\") (no-italic . \"22\") (underline . \"4\") (no-underline . \"24\") (blink . \"5\") (no-blink . \"25\") (reverse . \"7\") (no-reverse . \"27\") (black . \"30\") (bg-black . \"40\") (red . \"31\") (bg-red . \"41\") (green . \"32\") (bg-green . \"42\") (yellow . \"33\") (bg-yellow . \"43\") (blue . \"34\") (bg-blue . \"44\") (magenta . \"35\") (bg-magenta . \"45\") (cyan . \"36\") (bg-cyan . \"46\") (white . \"37\") (bg-white . \"47\")) \"\" \"\\x1b;[\" \"m\" \"\" \"\" \";\" \"38;5;~a\" \"48;5;~a\" \";\" \"bad command ~S\" \"TERM\" getenv \"\" #:interactive regexp-match (\"rxvt\" \"xterm\" \"xterm-color\" \"linux\" \"cygwin\" \"cons25\") \"\" do-color input-port? port->list \"bad port ~S\" %port->list \"bad port ~S\" copy-port port->string port->sexp-list read-line port->string-list print printerr flush-output-port printf declare-new-error (lambda (name) (let ((cond-name (string->symbol (format \"&~a\" name))) (predicate (string->symbol (format \"&~a?\" name))) (args (gensym))) `(begin (define-condition-type ,cond-name &error-message ,predicate) (define (,name unquote args) (if (and (not (null? ,args)) (symbol? (car ,args))) (apply signal-error ,cond-name ,args) (apply signal-error ,cond-name ',name ,args)))))) \"&~a\" \"&~a?\" define-condition-type &error-message signal-error \"| \" exec \"| \" exec-list string apropos \"bad module ~S\" sort string-find? \"**** ~A\\n**** EXIT\\n\" exit die running-os cygwin-windows posixify-file-name #\\/ \"/\" \".\" \"/\" decompose-file-name \"^(.*)/(.+)$\" \"\\\\1\" regexp-replace \"\" string=? \"/\" \".\" \"^(.*)/(.*)$\" \"\\\\2\" basename \"/\" \".\" \"/\" \"^(.*)/(.+)$\" \"\\\\1\" \"\" \"/\" \".\" \"^(.*)/(.*)$\" \"\\\\2\" (unix cygwin-windows android) windows #\\\\ #\\? file-separator \"~A~A~A\" #\\. file-suffix file-prefix port-idle-register! \"bad procedure ~S\" %port-idle port-idle-unregister! \"bad procedure ~S\" port-idle-reset! expand-file-name %chmod bit-or write execute chmod \"bad option ~S\" \"bad option ~S\" mutex-lock! mutex-unlock! with-mutex error-object? \"bad error object: ~S\" error-object-location define-constant (lambda args (define (rewrite l) (if (<= (length l) 1) (error \"bad constant definition\")) (let ((bind (car l)) (body (cdr l))) (if (pair? bind) (rewrite `(,(car bind) (lambda ,(cdr bind) ,@body))) l))) (let ((args (rewrite args))) (if (= (length args) 2) `(begin (define ,@args) (symbol-immutable! ',(car args))) (error \"bad constant definition ~S\" `(define-constant ,@args))))) \"bad constant definition\" symbol-immutable! \"bad constant definition ~S\" void? real? \"bad real number ~S\" 3.14159265358979 radians->degrees \"bad real number ~S\" 3.14159265358979 degrees->radians %stable-version? \"stable\" %stklos-git #:commit \"unstable -- ~a\" \"unstable\" %push-id receive (lambda (vars producer . body) `(call-with-values (lambda () ,producer) (lambda ,vars ,@body))) case-lambda (lambda clauses (let ((len (gensym)) (args (gensym)) (compute-arity (in-module STKLOS-COMPILER compute-arity))) `(lambda ,args (let ((,len (length ,args))) (cond ,@(map (lambda (x) (unless (>= (length x) 2) (error 'case-lambda \"bad clause ~S\" x)) (let* ((formals (car x)) (body (cdr x)) (arity (compute-arity formals))) (cond ((positive? arity) `((= ,len ,arity) (apply (lambda ,formals ,@body) ,args))) ((zero? arity) `((= ,len ,arity) ,@body)) (else `((>= ,len ,(- (- arity) 1)) (apply (lambda ,formals ,@body) ,args)))))) clauses) (else (error 'case-lambda \"no matching clause in list ~S for ~S\" ',(map car clauses) ,args))))))) \"bad clause ~S\" \"no matching clause in list ~S for ~S\" %define-condition-type-accessors (lambda (name supertype predicate . slots) (let ((obj (gensym))) `(begin (define (,predicate ,obj) (and (condition? ,obj) (condition-has-type? ,obj ,name))) ,@(map (lambda (x) `(define (,(cadr x) ,obj) (unless (,predicate ,obj) (error ',(cadr x) \"bad type for condition ~S\" ,obj)) (condition-ref ,obj ',(car x)))) slots)))) \"bad type for condition ~S\" &message message-condition? &serious serious-condition? &error error? error-message? error-location error-message read-with-shared-structure write* write-with-shared-structure read/ss write/ss parameterize (lambda (bindings . body) (let ((tmp1 (map (lambda (_) (gensym)) bindings)) (tmp2 (map (lambda (_) (gensym)) bindings))) `(let (,@(map (lambda (x y) (list y (cadr x))) bindings tmp1) ,@(map (lambda (x y) (list y (list (car x)))) bindings tmp2)) (dynamic-wind (lambda () ,@(map (lambda (x y) `(,(car x) ,y)) bindings tmp1)) (lambda () ,@body) (lambda () ,@(map (lambda (x y) `(,(car x) ,y)) bindings tmp2)))))) require-extension (lambda args (%find-macro-clause 'require-extension args '(require-extension srfi) '(((_ \"internal\" (srfi id ...)) (begin (require-feature id) ...)) ((_ \"internal\" (x ...)) (import (x ...))) ((_ \"internal\" id) (cond-expand (id #void) (else (error \"cannot require extension named '~s'\" 'id)))) ((_ clause ...) (begin (require-extension \"internal\" clause) ...))) '...)) (require-extension srfi) (((_ \"internal\" (srfi id ...)) (begin (require-feature id) ...)) ((_ \"internal\" (x ...)) (import (x ...))) ((_ \"internal\" id) (cond-expand (id #void) (else (error \"cannot require extension named '~s'\" 'id)))) ((_ clause ...) (begin (require-extension \"internal\" clause) ...))) \"bad string ~S\" get-environment-variable get-environment-variables \"STklos\" implementation-name implementation-version %uname cpu-architecture machine-name os-name \" \" os-version fixnum-width fx-width greatest-fixnum fx-greatest least-fixnum fx-least assume (lambda (expr . args) (if (positive? (stklos-debug-level)) (let* ((efile (and (%epair? expr) (%epair-file expr))) (eline (and (%epair? expr) (%epair-line expr))) (fmt (string-append (if efile (format \"in ~A:~A, \" efile eline) \"\") \"invalid assumption:\"))) `(or ,expr (error ,fmt ',expr ,@args))) #void)) \"in ~A:~A, \" \"\" \"invalid assumption:\" \"srfi-\" %stklos-configure features #:use-utf8 command \"stklos\" scheme.id languages scheme r5rs r7rs encodings (utf-8) threads %thread-system install-dir website \"https://stklos.net\" scheme.features scheme.path scheme.srfi scheme.srfi.count build.configure #:configure build.git.tag #:tag build.git.branch #:branch build.git.commit build.git.modified #:modified c.version #:c-version c.compile #:c-compile c.link #:c-link c.type-bits #:c-type-bits c.library.compile #:shlib-compile c.library.link #:shlib-link c.library.extension #:shlib-suffix stklos.system-libs #:system stklos.compiled-libs #:compiled os.uname os.env.LANG \"LANG\" \"\" os.env.TERM \"TERM\" \"\" version-alist port? port-has-port-position? \"Not a port: ~A\" port-current-position port-position port-has-set-port-position!? \"Not a port: ~A\" output-port? flush port-seek set-port-position! &i/o-bad-parameter parameter make-i/o-invalid-position-error obj i/o-invalid-position-error? \"\" *load-suffixes* command-name command-args argc \"\" \"\" script-file \"\" \"\" \"/\" script-directory %make-nan make-nan ((regexp-replace . regexp-replace) (regexp-replace-all . regexp-replace-all)) regexp-replace-all \"\\\\\\\\[0-9]\" regexp-match-positions \"cannot match \\\\~A in model\" ((run-process . run-process) (process-kill . process-kill) (process-stop . process-stop) (process-continue . process-continue)) \"value expected after keyword ~S\" #:input #:output #:error #:wait #:fork #:args %run-process run-process SIGTERM process-send-signal process-kill SIGSTOP process-stop SIGCONT process-continue ((%equiv? . %equiv?)) %equiv? %equal-try ((time? . time?) (time->seconds . time->seconds) (seconds->time . seconds->time) (make-date . make-date) (date? . date?) (seconds->date . seconds->date) (date-nanosecond . date-nanosecond) (date-second . date-second) (date-minute . date-minute) (date-hour . date-hour) (date-day . date-day) (date-month . date-month) (date-year . date-year) (date-week-day . date-week-day) (date-year-day . date-year-day) (date-dst . date-dst) (date-tz . date-tz) (time-zone-name . time-zone-name) (seconds->list . seconds->list) (current-date . current-date) (current-time . current-time) (seconds->string . seconds->string) (date->string . date->string) (time-nanosecond . time-nanosecond) (set-time-nanosecond! . set-time-nanosecond!) (time-second . time-second) (set-time-second! . set-time-second!) (time-type . time-type) (set-time-type! . set-time-type!) (make-time . make-time) (time-tai->time-utc . time-tai->time-utc) (time-tai->time-utc! . time-tai->time-utc!) (time-utc->time-tai . time-utc->time-tai) (time-utc->time-tai! . time-utc->time-tai!) (%leap-second-table . %leap-second-table) (%leap-second-delta . %leap-second-delta) (%time-tai->time-utc! . %time-tai->time-utc!) (%time-utc->time-tai! . %time-utc->time-tai!)) \"since first argument is symbol, 3 args (type, nanosecond and second) required, only 2 given\" (time-tai time-utc time-monotonic time-process time-duration) \"bad time type ~S\" \"bad integer ~S\" \"bad integer ~S\" %time \"since first argument is integer, 2 args (nanosecond and second) required, but 3 given\" \"bad integer ~S\" time-utc \"bad symbol or integer ~S\" make-time type time-type set-time-type! second time-second set-time-second! nanosecond time-nanosecond set-time-nanosecond! struct-type time? 1000000000 %nano 86400 %sid exact->inexact time-seconds \"bad time ~S\" time->seconds inexact->exact #:time-utc seconds->time \"cannot convert ~S to a time\" \"bad number ~S\" ((1483228800 . 37) (1435708800 . 36) (1341100800 . 35) (1230768000 . 34) (1136073600 . 33) (915148800 . 32) (867715200 . 31) (820454400 . 30) (773020800 . 29) (741484800 . 28) (709948800 . 27) (662688000 . 26) (631152000 . 25) (567993600 . 24) (489024000 . 23) (425865600 . 22) (394329600 . 21) (362793600 . 20) (315532800 . 19) (283996800 . 18) (252460800 . 17) (220924800 . 16) (189302400 . 15) (157766400 . 14) (126230400 . 13) (94694400 . 12) (78796800 . 11) (63072000 . 10)) %leap-second-table %leap-second-delta %leap-second-neg-delta time-tai \"bad TAI time ~S\" %time-tai->time-utc! time-tai->time-utc time-tai->time-utc! \"bad UTC time ~S\" %time-utc->time-tai! time-utc->time-tai time-utc->time-tai! current-second %get-time-of-day %current-time-tai %current-time-utc %current-time \"too many arguments (0 or 1 expected, ~S given)\" \"unsupported time type ~S\" current-time %make-date-key %make-date-opt make-date #:nanosecond #:second #:minute #:hour #:day #:month #:year #:zone-offset %make-date \"bad ~s ~s\" check 999999999 minute hour day month \"bad year ~s\" \"bad zone offset ~s\" %date max date->seconds seconds->date local-timezone-offset week-day date-week-day year-day date-year-day dst date-dst tz date? date-tz \"Z\" abs #\\- \"~a~2f:~2f\" #\\0 string-map time-zone-name %seconds->date \"#[date ~A-~A-~A ~A:~A:~A]\" year struct-type-change-writer! date-nanosecond date-second date-minute date-hour date-day date-month date-year struct->list seconds->list current-date seconds->string \"bad string ~S\" #\\% \"%%\" #\\~ %seconds->string \"~c\" date->string \"bad string ~S\" ((bit-and . bit-and) (bit-or . bit-or) (bit-xor . bit-xor) (bit-not . bit-not) (bit-shift . bit-shift)) bit-and bit-xor %bit-and %bit-or %bit-xor bit-not bit-shift ((make-thread . make-thread) (thread-handler-error-show . thread-handler-error-show) (thread-sleep! . thread-sleep!) (thread-join! . thread-join!) (mutex-lock! . mutex-lock!) (mutex-unlock! . mutex-unlock!) (join-timeout-exception? . join-timeout-exception?) (abandoned-mutex-exception? . abandoned-mutex-exception?) (terminated-thread-exception? . terminated-thread-exception?) (&uncaught-exception . &uncaught-exception) (uncaught-exception? . uncaught-exception?) (uncaught-exception-reason . uncaught-exception-reason)) \"bad timeout ~S\" %thread-timeout->seconds \"thread\" current-thread thread-name %build-error-location bold red \"**** Error \" blue \"(in thread ~S):\\n\" \"~A: ~A\\n\" normal \" (this error may be signaled again later)\\n\" %thread-end-exception-set! thread-handler-error-show %make-thread make-thread thread-sleep! \"cannot used #f as timeout\" %thread-sleep! thread-join! \"cannot join on myself (deadlock will occur)\" %thread-join! &thread-join-timeout %thread-end-exception &uncaught-exception reason %thread-end-result %mutex-lock! thread? &thread-abandonned-mutex %mutex-unlock! join-timeout-exception? abandoned-mutex-exception? &thread-terminated terminated-thread-exception? &condition (reason) make-condition-type uncaught-exception? uncaught-exception-reason ((make-external-function . make-external-function) (make-callback . make-callback) (define-external . define-external)) make-external-function make-callback ((#:void 0) (#:char 1) (#:short 2) (#:ushort 3) (#:int 4) (#:uint 5) (#:long 6) (#:ulong 7) (#:lonlong 8) (#:ulonlong 9) (#:float 10) (#:double 11) (#:boolean 12) (#:pointer 13) (#:string 14) (#:int8 15) (#:int16 16) (#:int32 17) (#:int64 18) (#:obj 19)) define-external \"parameter of type :void are forbidden\" \"bad type name ~S\" \"bad parameter description: ~S\" \"bad parameter description: ~S\" %make-ext-func %make-callback (lambda (name parameters . args) (let* ((lib (key-get args #:library-name \"\")) (lib-name (if (and (equal? lib \"\") (equal? (running-os) 'cygwin-windows)) \"cygwin1.dll\" lib)) (entry-name (key-get args #:entry-name (symbol->string name))) (return-type (key-get args #:return-type #:void))) `(define ,name (make-external-function ,entry-name ',parameters ,return-type ,lib-name)))) #:library-name \"\" \"\" \"cygwin1.dll\" #:entry-name #:return-type #:void ((write-shared . write-shared) (write-simple . write-simple) (letrec* . letrec*) (let-values . let-values) (let*-values . let*-values) (delay . delay) (delay-force . delay-force) (lazy . lazy) (make-promise . make-promise) (eager . eager) (define-values . define-values) (define-record-type . define-record-type) (equal-simple? . equal-simple?) (exact-integer? . exact-integer?) (floor-quotient . floor-quotient) (floor/ . floor/) (truncate/ . truncate/) (truncate-quotient . truncate-quotient) (truncate-remainder . truncate-remainder) (floor-remainder . floor-remainder) (square . square) (exact-integer-sqrt . exact-integer-sqrt) (exact . exact) (inexact . inexact) (boolean=? . boolean=?) (make-list . make-list) (member-simple . member-simple) (assoc-simple . assoc-simple) (member . member) (assoc . assoc) (symbol=? . symbol=?) (string=? . string=?) (%string2=? . %string2=?) (string . string) (%string2 . %string2) (string<=? . string<=?) (%string2<=? . %string2<=?) (string>? . string>?) (%string2>? . %string2>?) (string>=? . string>=?) (%string2>=? . %string2>=?) (string-ci=? . string-ci=?) (%string-ci2=? . %string-ci2=?) (string-ci . string-ci) (%string-ci2 . %string-ci2) (string-ci<=? . string-ci<=?) (%string-ci2<=? . %string-ci2<=?) (string-ci>? . string-ci>?) (%string-ci2>? . %string-ci2>?) (string-ci>=? . string-ci>=?) (%string-ci2>=? . %string-ci2>=?) (string->list . string->list) (string-copy! . string-copy!) (string-fill! . string-fill!) (%string-fill2! . %string-fill2!) (vector->list . vector->list) (vector-copy! . vector-copy!) (vector->string . vector->string) (string->vector . string->vector) (make-bytevector . make-bytevector) (bytevector? . bytevector?) (bytevector . bytevector) (bytevector-length . bytevector-length) (bytevector-u8-ref . bytevector-u8-ref) (bytevector-u8-set! . bytevector-u8-set!) (bytevector-copy! . bytevector-copy!) (string-map . string-map) (vector-map . vector-map) (string-for-each . string-for-each) (vector-for-each . vector-for-each) (error-object? . error-object?) (error-object-message . error-object-message) (error-object-irritants . error-object-irritants) (read-error? . read-error?) (file-error? . file-error?) (call-with-port . call-with-port) (input-port-open? . input-port-open?) (output-port-open? . output-port-open?) (read-string . read-string) (read-u8 . read-u8) (peek-u8 . peek-u8) (read-bytevector! . read-bytevector!) (write-string . write-string) (write-u8 . write-u8) (write-bytevector . write-bytevector) (with-exception-handler . with-exception-handler) (raise-continuable . raise-continuable) (guard . guard) (current-jiffy . current-jiffy) (jiffies-per-second . jiffies-per-second) (features . features) (%continuable-exception? . %continuable-exception?) (%continuable-exception-value . %continuable-exception-value)) write-shared write-simple letrec* (lambda (bindings . body) (if (list? bindings) (for-each (lambda (x) (unless (and (list? x) (= (length x) 2)) (error 'letrec* \"incorrect binding ~S\" x))) bindings) (error 'letrec* \"incorrect bindings ~S\" bindings)) `(let ,(map (lambda (x) (list (car x) #f)) bindings) ,@(map (lambda (x) `(set! ,@x)) bindings) (let () ,@body))) \"incorrect binding ~S\" \"incorrect bindings ~S\" let-values (lambda (bindings . body) (let ((tmps '())) (define (expand-once bindings tmps) (let ((first (car bindings))) `(call-with-values (lambda () ,(cadr first)) (lambda ,(map* (lambda (x) (cadr (assoc x tmps))) (car first)) ,(if (= (length bindings) 1) `(let ,tmps ,@body) (expand-once (cdr bindings) tmps)))))) (define (parse-binding binding) (unless (and (list? binding) (= (length binding) 2) (or (pair? (car binding)) (symbol? (car binding)))) (error 'let-values \"incorrect binding ~S\" binding)) (for-each* (lambda (x) (if (assoc x tmps) (error 'let-values \"duplicate binding ~s\" x) (set! tmps (cons (list x (gensym)) tmps)))) (car binding))) (for-each parse-binding bindings) (if (null? tmps) `(let () ,@body) (expand-once bindings tmps)))) \"incorrect binding ~S\" \"duplicate binding ~s\" let*-values (lambda (bindings . body) (if (> (length bindings) 1) `(let-values (,(car bindings)) (let*-values ,(cdr bindings) ,@body)) `(let-values ,bindings ,@body))) delay (lambda (exp) `(delay-force (%make-promise (list ,exp)))) delay-force %make-promise (lambda (exp) `(%make-promise (lambda () ,exp))) lazy (lambda (expr) `(delay-force ,expr)) promise? make-promise eager define-values (lambda (formals expr) (define (flat lst) (cond ((null? lst) lst) ((pair? lst) (cons (car lst) (flat (cdr lst)))) (else (list lst)))) (if (null? formals) `(call-with-values (lambda () ,expr) void) (let* ((tmps (map* (lambda (x) (gensym)) formals)) (ff (flat formals)) (ft (flat tmps))) `(begin ,@(map (lambda (x) `(define ,x #void)) ff) (call-with-values (lambda () ,expr) (lambda ,tmps ,@(map (lambda (x y) `(set! ,x ,y)) ff ft))) (values (void) ',formals))))) define-record-type (lambda (name constructor predicate . fields) (let ((struct-type (gensym)) (tmp (gensym)) (val (gensym))) `(begin (define ,(car constructor) #f) (define ,predicate #f) ,@(map (lambda (x) (case (length x) ((2) `(define ,(cadr x) #f)) ((3) `(begin (define ,(cadr x) #f) (define ,(caddr x) #f))) (else (error 'define-record-type \"bad field specification ~S\" x)))) fields) (let ((make-struct-type (%%in-scheme 'make-struct-type)) (make-struct (%%in-scheme 'make-struct)) (struct? (%%in-scheme 'struct?)) (struct-is-a? (%%in-scheme 'struct-is-a?)) (struct-ref (%%in-scheme 'struct-ref)) (struct-set! (%%in-scheme 'struct-set!))) (let ((,struct-type (make-struct-type ',name #f ',(map car fields)))) (set! ,(car constructor) (lambda ,(cdr constructor) (let ((,tmp (make-struct ,struct-type))) ,@(map (lambda (x) `(struct-set! ,tmp ',x ,x)) (cdr constructor)) ,tmp))) (set! ,predicate (lambda (,tmp) (and (struct? ,tmp) (struct-is-a? ,tmp ,struct-type)))) ,@(map (lambda (x) (if (= (length x) 2) `(set! ,(cadr x) (lambda (,tmp) (struct-ref ,tmp ',(car x)))) `(begin (set! ,(cadr x) (lambda (,tmp) (struct-ref ,tmp ',(car x)))) (set! ,(caddr x) (lambda (,tmp ,val) (struct-set! ,tmp ',(car x) ,val)))))) fields) (values (void) ',name)))))) \"bad field specification ~S\" equal-simple? exact-integer? floor-quotient floor-remainder floor/ truncate/ truncate-quotient truncate-remainder modulo square integer-length \"non negative integer expected. It was: ~S\" sqrt exact-integer-sqrt inexact boolean=? make-list member-simple assoc-simple symbol=? %generalize-string-compare (lambda (func func2) `(begin (define ,func2 ,func) (set! ,func (lambda (first . l) ,(string->keyword (symbol->string func)) (letrec ((compare (lambda (first . l) (or (null? l) (and (,func2 first (car l)) (apply compare l)))))) (unless (string? first) (error \"bad string ~W\" first)) (apply compare first l)))))) first l compare \"bad string ~W\" %string2=? %string2 string<=? %string2<=? string>? %string2>? string>=? %string2>=? string-ci=? %string-ci2=? string-ci %string-ci2 string-ci<=? %string-ci2<=? string-ci>? %string-ci2>? string-ci>=? %string-ci2>=? string-copy! \"bad string ~S\" \"bad string ~S\" \"bad destination index ~S\" \"bad integer for start index ~S\" \"bad integer for end index ~S\" \"not enough room in destination string ~S\" string-fill! %string-fill2! \"end index ~S < start index ~S\" vector-copy! \"bad vector ~S\" \"bad vector ~S\" \"bad destination index ~S\" \"bad integer for start index ~S\" \"bad integer for end index ~S\" \"not enough room in destination vector ~S\" \"bad vector ~S\" vector->string char? \"element at index ~S of ~S must be a character\" \"bad string ~S\" string->vector make-bytevector %make-uvector %uvector? bytevector? bytevector %uvector bytevector-length %uvector-length bytevector-u8-ref %uvector-ref bytevector-u8-set! %uvector-set! bytevector-copy! \"bad bytevector ~S\" \"bad bytevector ~S\" \"bad destination index ~S\" \"bad integer for start index ~S\" \"bad integer for end index ~S\" \"not enough room in destination bytevector ~S\" \"bad string ~S\" \"bad character in ~S\" vector-map \"bad list of vectors ~S\" string-for-each \"bad string ~S\" vector-for-each \"bad list of vectors ~S\" \"bad error object: ~S\" error-object-message \"bad error object: ~S\" error-object-irritants &read-error read-error? file-error? call-with-port \"bad input port ~S\" port-closed? input-port-open? \"bad output port ~S\" output-port-open? read-string \"parameter must be a positive integer. It was: ~S\" textual-port? \"bad textual input port ~S\" read-char eof-object read-u8 binary-port? \"bad binary port ~S\" read-byte peek-u8 \"bad binary port ~S\" peek-byte read-bytevector! \"bad bytevector ~S\" %read-bytevector! write-string %write-string write-u8 \"bad binary port ~S\" write-byte write-bytevector \"bad bytevector ~S\" \"bad binary port ~S\" %continuable-exception (value) make-%continuable-exception %continuable-exception? %continuable-exception-value \"exception handler returned on non-continuable exception\" with-exception-handler current-exception-handler raise-continuable guard (lambda (clauses . body) (let* ((var (car clauses)) (last (last-pair clauses)) (ex (gensym)) (old-hdlr (gensym)) (reraised (gensym)) (res (gensym))) `(let ((,old-hdlr (current-exception-handler))) (with-handler (lambda (,ex) (let* ((,var (if (%continuable-exception? ,ex) (%continuable-exception-value ,ex) ,ex)) (,reraised #f) (,res (cond ,@(cdr clauses) ,@(if (and (pair? last) (pair? (car last)) (eq? (caar last) 'else)) '() `((else (set! ,reraised #t) (,old-hdlr ,ex))))))) (if ,reraised ,res (if (%continuable-exception? ,ex) (raise ,res) ,res)))) ,@body)))) current-jiffy jiffies-per-second *all-features* SRFI-0 ((build-path-from-shell-variable . build-path-from-shell-variable) (load-path . load-path) (load-suffixes . load-suffixes) (load-verbose . load-verbose) (current-loading-file . current-loading-file) (try-load . try-load) (load . load) (find-path . find-path) (require . require) (provide . provide) (provided? . provided?) (require/provide . require/provide) (warning-when-not-provided . warning-when-not-provided) (require-library . require-library) (require-for-syntax . require-for-syntax) (include . include) (include-ci . include-ci) (include-file . include-file) (autoload . autoload) (%stklos-conf-dir . %stklos-conf-dir) (%stklos-conf-file . %stklos-conf-file) (%try-load-conditions . %try-load-conditions) (%do-include . %do-include) (%%require . %%require)) \";\" \":\" *path-separator* %shared-suffix \"ostk\" \"stk\" \"sld\" \"scm\" *load-verbose* *load-path* \"HOME\" \".stklos\" \"XDG_CONFIG_HOME\" \"STKLOS_CONFDIR\" \"~/.config\" \"stklos\" %stklos-conf-dir %stklos-conf-file build-path-from-shell-variable \"STKLOS_LOAD_PATH\" \".\" lib \"bad list of path names ~S\" \"bad path name ~S\" \"bad list of suffixes ~S\" \"bad path name ~S\" load-suffixes load-verbose current-loading-file \"%guess-pathname: trying ~S\\n\" file-is-readable? \".\" \"/\" %guess-pathname \"path must be a string (it was ~s)\" \".?.?/\" try-load %primitive-try-load %try-load-conditions \";; Loading file ~S.\\n\" \";; File ~S loaded.\\n\" %try-load load \"cannot load file ~S\" \"cannot load file\" %cannot-load %load require provide provided? warning-when-not-provided \"^srfi-([1-9][0-9]*)$\" \"srfi/~a\" %rewrite-require-spec \"STKLOS_BUILDING\" \"WARNING: ~S was not provided~%\" provided (lambda (what) (if (string? what) (let ((spec (%rewrite-require-spec what (load-path) (load-suffixes)))) (if (and spec (cdr spec)) `(begin (define-module STklos (import ,(cdr spec))) (provide ,what)) `(%%require ,what #f))) `(%%require ,what #f))) require-library (lambda (what) `(%%require ,what #t)) require-for-syntax (lambda (file) `(%%require4syntax ,file)) %%require4syntax %do-include (lambda (kind files) (let ((inc (string->symbol (format \"%%~a\" kind)))) (if (null? files) (error kind \"at least one parameter must be provided\") `(,inc ,@(map (lambda (x) (or (find-path x) x)) files))))) \"%%~a\" \"at least one parameter must be provided\" (lambda files `(%do-include include ,files)) (lambda files `(%do-include include-ci ,files)) include-file (lambda (file) `(%%include ,file)) autoload (lambda (file . symbols) (let ((args (gensym)) (old (gensym))) `(begin ,@(map (lambda (x) `(define ,x (lambda ,args (let ((,old ,x)) (require ,file) (if (eq? ,old ,x) (error 'autoload \"~S has not been defined in ~S\" ',x ,file) (apply ,x ,args)))))) symbols)))) \"~S has not been defined in ~S\" ((define-library . define-library) (library-name . library-name) (library-list . library-list) (%module-define-and-export . %module-define-and-export) (%make-copy-module . %make-copy-module)) %module-define-and-export (lambda lst `(begin ,@(map (lambda (x) `(%symbol-define ',x ,x)) lst) (export ,@lst))) %make-copy-module (lambda (old new) (%%import (compiler-current-module) (list old)) `(define-module ,new (import ,old) (export ,@(module-exports (find-module old))))) define-library (lambda (name . decls) (let* ((module-name (%normalize-library-name name)) (conds '()) (imports '()) (exports '()) (body '()) (lib (gensym)) (module-restore (symbol-value '%module-restore (find-module 'SCHEME)))) (define (parse-declarations decls) (for-each (lambda (d) (unless (pair? d) (error 'define-library \"bad library declaration clause ~s\" d)) (let ((key (car d)) (rest (cdr d))) (case key ((import) (set! imports (append imports rest))) ((export) (set! exports (append exports rest))) ((begin include include-ci) (set! body (append body (list d)))) ((include-library-declarations) (for-each (lambda (path) (parse-declarations (call-with-input-file (or (find-path path) path) port->sexp-list))) rest)) ((cond-expand) (set! conds (cons d conds))) (else (error 'define-library \"incorrect directive ~s\" d))))) decls)) (parse-declarations decls) `(begin (define-module ,module-name (begin ,@(reverse! conds)) (import ,@imports) (export ,@exports) (%module->library! ',module-name) ,@body)))) \"bad library declaration clause ~s\" (begin include include-ci) include-library-declarations cond-expand \"incorrect directive ~s\" %module->library! library-name \"module ~S is not a library\" \"bad module/library ~S\" library-list ((string-lower . string-lower) (string-upper . string-upper) (set-load-path! . set-load-path!) (set-load-suffixes! . set-load-suffixes!) (flush . flush) (rewind-file-port . rewind-file-port) (hash-table->list . hash-table->list) (hash-table-put! . hash-table-put!) (hash-table-get . hash-table-get) (hash-table-remove! . hash-table-remove!) (stklos-pragma . stklos-pragma) (remove-directory . remove-directory) (%build-path-from-shell-variable . %build-path-from-shell-variable) (copy-tree . copy-tree) (%set-std-port! . %set-std-port!) (make-box . make-box) (make-constant-box . make-constant-box) (box-set! . box-set!) (string-index . string-index) (argv . argv) (fxdiv . fxdiv) (fxrem . fxrem) (fxmod . fxmod) (fx< . fx<) (fx<= . fx<=) (fx> . fx>) (fx>= . fx>=) (fx= . fx=) (make-directory . make-directory) (make-directories . make-directories) (process-signal . process-signal) (compiler:generate-signature . compiler:generate-signature)) string-downcase string-lower string-upper \"*** Obsolete function set-load-path!. Use load-path instead.\\n\" set-load-path! \"*** Obsolete function set-load-suffixes!. Use load-suffixes instead.\\n\" set-load-suffixes! port-rewind rewind-file-port hash-table->list hash-table-put! hash-table-get hash-table-delete! hash-table-remove! \"Don't use anymore pragma, but compiler:warn-use-undef parameter\" stklos-pragma pragma define-reader-ctor delete-directory remove-directory %build-path-from-shell-variable copy-tree %set-std-port! \"bad port number\" box make-box constant-box make-constant-box set-box! box-set! string-index argv fxdiv fxremainder fxrem fxmodulo fxmod make-directory make-directories process-signal %file-informations STKLOS-OBJECT ((SCHEME)) ((find-class . find-class) (is-a? . is-a?) (ensure-metaclass . ensure-metaclass) (ensure-metaclass-with-supers . ensure-metaclass-with-supers) (ensure-class . ensure-class) (ensure-generic-function . ensure-generic-function) (ensure-method . ensure-method) (add-method! . add-method!) (object-eqv? . object-eqv?) (object-equal? . object-equal?) (write-object . write-object) (display-object . display-object) (slot-unbound . slot-unbound) (slot-missing . slot-missing) (slot-definition-name . slot-definition-name) (slot-definition-options . slot-definition-options) (slot-definition-allocation . slot-definition-allocation) (slot-definition-getter . slot-definition-getter) (slot-definition-setter . slot-definition-setter) (slot-definition-accessor . slot-definition-accessor) (slot-definition-init-form . slot-definition-init-form) (slot-definition-init-keyword . slot-definition-init-keyword) (slot-init-function . slot-init-function) (class-slot-definition . class-slot-definition) (compute-get-n-set . compute-get-n-set) (allocate-instance . allocate-instance) (initialize . initialize) (make-instance . make-instance) (make . make) (no-next-method . no-next-method) (no-applicable-method . no-applicable-method) (no-method . no-method) (change-class . change-class) (change-object-class . change-object-class) (shallow-clone . shallow-clone) (deep-clone . deep-clone) (apply-generic . apply-generic) (apply-method . apply-method) (apply-methods . apply-methods) (compute-applicable-methods . compute-applicable-methods) (method-more-specific? . method-more-specific?) (sort-applicable-methods . sort-applicable-methods) (method-procedure . method-procedure) (method-specializers . method-specializers) (method-generic-function . method-generic-function) (method-specializers-equal? . method-specializers-equal?) (class-subclasses . class-subclasses) (class-methods . class-methods) (class-name . class-name) (class-direct-superclasses . class-direct-superclasses) (class-direct-subclasses . class-direct-subclasses) (class-precedence-list . class-precedence-list) (class-direct-methods . class-direct-methods) (class-direct-slots . class-direct-slots) (class-slots . class-slots) (generic-function-name . generic-function-name) (generic-function-methods . generic-function-methods) (generic-function-documentation . generic-function-documentation) (slot-value . slot-value) (define-class . define-class) (define-generic . define-generic) (method . method) (define-method . define-method)) class-redefinition \"bad class ~S\" %error-bad-class \"bad generic function ~S\" %error-bad-generic \"bad method ~S\" %error-bad-method make-closure specializers formals slot-definition-getter slot-definition-setter slot-definition-accessor declare-slots generic #:name ??? %make #:generic-function #:specializers #:procedure basic-make \"cannot make ~S with ~S\" make class? name class-name direct-supers class-direct-superclasses direct-slots class-direct-slots direct-subclasses class-direct-subclasses direct-methods class-direct-methods cpl class-precedence-list slots class-slots slot-definition-name slot-definition-options #:instance #:allocation slot-definition-allocation #:getter #:accessor #:init-form slot-definition-init-form #:init-keyword slot-definition-init-keyword getters-n-setters slot-init-function class-slot-definition generic-function-name methods generic-function-methods documentation generic-function-documentation method? generic-function method-generic-function method-specializers procedure method-procedure class-of is-a? find-class \"bad class ~S\" compute-slots \"bad slot name ~S\" %compute-slots #:dsupers #:slots \"metaclass\" ensure-metaclass-with-supers ensure-metaclass define-class (lambda (name supers slots . options) `(define ,name (ensure-class ',name ',supers ',(declare-slots slots) ,(or (key-get options #:metaclass #f) `(ensure-metaclass ',supers)) ,@options))) ensure-class #:metaclass \"super class ~S is duplicated in class ~S\" \"slot ~S is duplicated in class ~S\" define-generic (lambda (gf #:optional (meta ') #:key (documentation #f)) `(define ,gf (ensure-generic-function ',gf ,meta ,documentation))) #:documentation ensure-generic-function #:default %method-specializers-equal? method-specializers-equal? add-method-in-classes! remove-method-in-classes! compute-new-list-of-methods add-method! next-method ensure-method (lambda (args . body) (ensure-method #f args body)) define-method (lambda (name args . body) (let ((gf (gensym \"gf\"))) `(let ((,gf (ensure-generic-function ',name))) (add-method! ,gf ,(ensure-method gf args body)) (values (void) ',name)))) \"gf\" object-eqv? ( ) object-equal? ( ) write-object ( ) \"#[instance ~A]\" address-of ( ) slot-bound? \"#[~A ~A]\" ( ) \"#[~A ~A ~A]\" ( ) \"#[~A ~A (~A)]\" display-object ( ) slot-unbound ( ) \"slot ~S is unbound in #p~A (an object of class ~S)\" slot-missing ( . ) \"no slot with name `~S' in #p~A (an object of class ~S)\" no-next-method ( ) \"no next method for ~S in call ~S\" no-applicable-method ( ) \"no applicable method for ~S\\nin call ~S\" no-method ( ) \"no method defined for ~S\" shallow-clone () %allocate-instance deep-clone () instance? remove-class-accessors update-direct-method update-direct-subclass () ( ) ( ) ( ) redefined %find-inherited-get-n-set %direct-slot? #:before-slot-ref #:after-slot-ref #:before-slot-set! #:after-slot-set! %fast-slot-ref %fast-slot-set! %make-active-getter-n-setter compute-get-n-set ( ) nfields #:class #:each-subclass #:virtual #:slot-ref #:slot-set! \"a :slot-ref and a :slot-set! must be supplied in ~S\" #:active ( ) \"allocation type \\\"~S\\\" is unknown\" compute-slot-accessors %slot-ref closure? %procedure-arity \"bad getter closure for slot `~S' in ~S: ~S\" \"bad setter closure for slot `~S' in ~S: ~S\" list* compute-getters-n-setters compute-cpl initialize ( ) %initialize-object ( ) ( ) ( ) allocate-instance ( ) make-instance ( . ) slot-exists-using-class? slot-bound-using-class? slot-ref-using-class slot-set-using-class! %modify-instance change-object-class change-class ( ) compute-applicable-methods ( ) find-method method-more-specific? ( ) %method-more-specific? sort-applicable-methods ( ) apply-method ( ) %set-next-method! apply-methods ( ) apply-generic ( ) ( ) class-subclasses class-methods slot-value ( ) ( ) %object-system-initialized ((STKLOS-OBJECT)) ((SCHEME)) ((let-syntax . let-syntax) (letrec-syntax . letrec-syntax)) letrec-syntax (lambda args (error 'letrec-syntax \"cannot be used here. You must load the file \\\"full-syntax\\\" to access it:\" (cons 'letrec-syntax args))) \"cannot be used here. You must load the file \\\"full-syntax\\\" to access it:\" some split \"list is too short\" hyg:untag-no-tags hyg:untag-vanilla hyg:untag-lambda hyg:untag-letrec hyg:untag-named-let hyg:untag-let hyg:untag-let* hyg:untag-do hyg:untag-list hyg:untag-list* hyg:untag-quasiquote hyg:flatten mbe:ellipsis? mbe:split-at-ellipsis mbe:get-ellipsis-nestings mbe:ellipsis-sub-envs mbe:contained-in? hyg:rassq hyg:tag hyg:untag (if begin) (set! define) \"takes exactly one expression\" \"invalid context within quasiquote\" \"takes exactly one expression\" list-tail \"%%\" mbe:position mbe:append-map split-improper-tail mbe:matches-pattern? mbe:get-bindings mbe:expand-pattern \"no matching clause for ~S\" let-syntax (lambda (bindings . body) `(%let-syntax ,(map (lambda (x) (let ((macro-name (car x)) (syn-rules (cadr x))) (let ((alt-ellipsis? (not (list? (cadr syn-rules))))) (let ((ellipsis (if alt-ellipsis? (cadr syn-rules) '...)) (keywords (if alt-ellipsis? (cons macro-name (caddr syn-rules)) (cons macro-name (cadr syn-rules)))) (clauses (if alt-ellipsis? (cdddr syn-rules) (cddr syn-rules)))) `(,macro-name (lambda args (%find-macro-clause ',macro-name args ',keywords ',clauses ',ellipsis))))))) bindings) ,@body)) ((SCHEME)) ((srfi0-register-feature! . srfi0-register-feature!) (srfi-0-feature-implementation-file . srfi-0-feature-implementation-file) (require-feature . require-feature) (cond-expand . cond-expand) (%srfi-0-expand . %srfi-0-expand)) (srfi-0 (srfi-1 . \"srfi-1\") (lists . \"srfi-1\") (srfi-2 . \"srfi-2\") (and-let* . \"srfi-2\") (srfi-4 . \"srfi-4\") (hvectors . \"srfi-4\") (srfi-5 . \"srfi-5\") srfi-6 (srfi-7 . \"srfi-7\") (program . \"srfi-7\") srfi-8 (srfi-9 . \"srfi-9\") (records . \"srfi-9\") srfi-10 srfi-11 (srfi-13 . \"srfi-13\") (srfi-14 . \"srfi-14\") srfi-15 srfi-16 case-lambda (srfi-17 . \"srfi-17\") srfi-18 (srfi-19 . \"srfi-19\") srfi-22 srfi-23 error (srfi-25 . \"srfi-25\") (srfi-26 . \"srfi-26\") (srfi-27 . \"srfi-27\") (random . \"srfi-27\") srfi-28 (srfi-29 . \"srfi-29\") srfi-30 srfi-31 srfi-34 (srfi-35 . \"srfi-35\") (srfi-36 . \"srfi-36\") (srfi-37 . \"srfi-37\") (args-fold . \"srfi-37\") srfi-38 srfi-39 parameters (srfi-41 . \"srfi-41\") (streams . \"srfi-41\") (srfi-43 . \"srfi-43\") srfi-45 srfi-46 (srfi-48 . \"srfi-48\") (srfi-51 . \"srfi-51\") (rest-list . \"srfi-51\") (srfi-54 . \"srfi-54\") (formatting . \"srfi-54\") srfi-55 (srfi-59 . \"srfi-59\") (srfi-60 . \"srfi-60\") (srfi-61 . \"srfi-61\") srfi-62 (srfi-64 . \"srfi-64\") (testing . \"srfi-64\") (srfi-66 . \"srfi-66\") (srfi-69 . \"srfi-69\") (hash-tables . \"srfi-69\") srfi-70 (srfi-74 . \"srfi-74\") srfi-87 srfi-88 (srfi-89 . \"srfi-89\") (srfi-94 . \"srfi-94\") (srfi-95 . \"srfi-95\") (srfi-96 . \"srfi-96\") srfi-98 (srfi-100 . \"srfi-100\") srfi-111 boxes srfi-112 (srfi-113 . \"srfi-113\") (sets-bags . \"srfi-113\") (srfi-116 . \"srfi-116\") (immutable-lists . \"srfi-116\") (srfi-117 . \"srfi-117\") (queues-as-lists . \"srfi-117\") srfi-118 adjustable-strings (srfi-125 . \"srfi-125\") (hash-table . \"srfi-125\") (srfi-127 . \"srfi-127\") (lazy-sequences . \"srfi-127\") (srfi-128 . \"srfi-128\") (comparators-reduced . \"srfi-128\") (srfi-129 . \"srfi-129\") (titlecase . \"srfi-129\") (srfi-130 . \"srfi-130\") (srfi-132 . \"srfi-132\") (sort . \"srfi-132\") (srfi-133 . \"srfi-133\") (vector . \"srfi-133\") (srfi-134 . \"srfi-134\") (immutable-deques . \"srfi-134\") (srfi-135 . \"srfi-135\") (immutable-texts . \"srfi-135\") (srfi-137 . \"srfi-137\") srfi-138 (srfi-141 . \"srfi-141\") (integer-division . \"srfi-141\") srfi-143 (srfi-144 . \"srfi-144\") srfi-145 (srfi-151 . \"srfi-151\") (bitwise-ops . \"srfi-151\") (srfi-152 . \"srfi-152\") (srfi-154 . \"srfi-154\") (srfi-156 . \"srfi-156\") (srfi-158 . \"srfi-158\") (srfi-160 . \"srfi-160\") (srfi-161 . \"srfi-161\") (srfi-162 . \"srfi-128\") srfi-169 (srfi-170 . \"srfi-170\") (posix . \"srfi-170\") (srfi-171 . \"srfi-171\") (transducers . \"srfi-171\") (srfi-173 . \"srfi-173\") (hooks . \"srfi-173\") (srfi-174 . \"srfi-174\") (posix-timespecs . \"srfi-174\") (srfi-175 . \"srfi-175\") (ascii . \"srfi-175\") srfi-176 (srfi-180 . \"srfi-180\") (JSON . \"srfi-180\") (json . \"srfi-180\") (srfi-185 . \"srfi-185\") (srfi-189 . \"srfi-189\") (maybe-either . \"srfi-189\") (srfi-190 . \"srfi-190\") srfi-192 srfi-193 srfi-195 (srfi-196 . \"srfi-196\") (srfi-207 . \"srfi-207\") srfi-208 (srfi-214 . \"srfi-214\") (srfi-215 . \"srfi-215\") (srfi-216 . \"srfi-216\") (srfi-217 . \"srfi-217\") srfi-219 (srfi-221 . \"srfi-221\") (srfi-222 . \"srfi-222\") (srfi-223 . \"srfi-223\") (srfi-224 . \"srfi-224\") (srfi-227 . \"srfi-227\") (srfi-228 . \"srfi-228\") (srfi-229 . \"srfi-229\") (srfi-230 . \"srfi-230\") (srfi-233 . \"srfi-233\") (ini-files . \"srfi-233\") (srfi-235 . \"srfi-235\") (combinators . \"srfi-235\") (srfi-236 . \"srfi-236\") (srfi-238 . \"srfi-238\") srfi-244 (conditions \"srfi-35\" \"srfi-36\") (generators \"srfi-158\" \"srfi-190\")) %srfi-feature-list \"STklos-\" \"id-\" #:debug (debug) almost-r7rs exact-complex ieee-float (full-unicode utf-8 UTF-8) ratios %big-endian? big-endian little-endian srfi0-register-feature! \"feature ~S is not supported\" srfi-0-feature-implementation-file srfi- \"bad feature\" \"srfi-[0-9]+\" \"srfi/~a\" require-feature %load-implementation %find-feature \"no clause match\" \"bad clause ~S\" \"invalid 'not' clause\" library \"invalid 'library' clause\" \"bad clause ~S\" \"~a\" %srfi-0-expand (lambda clauses (%srfi-0-expand clauses)) REPL ((SCHEME)) ((main-repl . main-repl) (repl . repl) (repl-prompt . repl-prompt) (repl-make-prompt . repl-make-prompt) (repl-display-prompt . repl-display-prompt) (repl-prompt-use-color? . repl-prompt-use-color?) (repl-change-default-ports . repl-change-default-ports) (main-repl-hook . main-repl-hook) (repl-theme . repl-theme) (get-repl-color . get-repl-color) (repl-show-startup-message . repl-show-startup-message)) interactive? repl-level repl-backtrace default-in default-out default-err classic #:prompt magenta #:help-prompt green #:help #:repl-depth yellow #:info monochrome minimal underline *repl-themes* repl-theme \"\" get-repl-color \"^[ \\t]*\" \"\" (help h ?) \"Available Commands:\\n- ,backtrace ,bt Show the stack when last error occurred\\n- ,cd Change current directory\\n- ,pwd Print working directory\\n- ,quit ,q Exit STklos\\n- ,shell ,! Run a shell command\\n- ,help ,? ,h This help\\n\" (quit q) (backtrace bt) %display-backtrace (shell !) system cd chdir pwd \"~S\\n\" \"bad command name: ~S. Type ,help for some help\\n\" do-repl-command %other-error-handlers %try-matching-condition %add-error-to-repl-handler \" (near line ~a in file ~s)\" \"\" \"**** Error~A:\\n~A: ~A\\n\" \"\\t(type \\\"\" \",help\" \"\\\" for more information)\\n\" display-error-message repl-handler &exit-r7rs retcode %pre-exit \"**** Unknown condition raised.\\n\" \"Condition type: ~A\\n\" struct-type-name \"Condition slots: ~S\\n\" \"**** The following non-condition was raised: ~S\\n\" \"\" repl-prompt repl-prompt-use-color? \"[~A] \" \"\" \"~A>\" \" \" \" \" make-prompt repl-make-prompt display-prompt repl-display-prompt #:startup-message repl-show-startup-message main-repl-hook #:in G478 #:out G479 #:err G480 repl-change-default-ports G485 G486 G487 \"\\n\" \";; ~A\\n\" repl %initialize-signals \"STklos version ~a (~a)\\n\" \"Copyright (C) 1999-2023 Erick Gallesio \\n\" \"[~a/~a/~a/~a]\\n\" machine-type #:readline no-readline utf8 no-utf8 \"Type ',h' for help\\n\" \" \\\\ \" \" \\\\ \" \" / \\\\ \" \" / \\\\ \" main-repl READLINE ((SCHEME)) ((try-initialize-readline . try-initialize-readline) (readline . readline) (add-history . add-history) (read-history . read-history) (write-history . write-history) (read-with-history . read-with-history) (rl-event-hook . rl-event-hook) (rl-input-timeout . rl-input-timeout) (rl-completer-function . rl-completer-function)) readline add-history read-history write-history rl-event-hook rl-input-timeout \"> \" \"\" read-with-history \"readline\" (#:string) #:pointer #eof cpointer->string free-bytes \"add_history\" (#:string) \"read_history\" (#:string) #:int \"write_history\" (#:string) \"rl_set_keyboard_input_timeout\" \"\" %get-symbol-address \"rl_set_keyboard_input_timeout\" (#:int) \"rl_event_hook\" \"el_set\" \"\" libedit try-initialize default-complete-function rl-completer-function readline-completion-generator %shared-library-suffix \"libreadline.\" \"libedit.\" \"readline-complete.\" %init-readline-completion-function try-initialize-readline REPL-READLINE ((SCHEME) (REPL) (READLINE)) ((try-initialize-repl-with-readline . try-initialize-repl-with-readline)) \"history\" \"\\x01;\" \"\\x02;\" \"\" \"\" nothing register-exit-function! #() %string->bytes \"\" #() #\\newline integer->char repl-readline-integration #:line-editor try-initialize-repl-with-readline trace (lambda args (%trace-expand args)) %trace-expand untrace (lambda args (%untrace-expand args)) %untrace-expand parse-arguments (lambda (argv . clauses) (%parse-arguments-expand argv clauses)) %parse-arguments-expand match-lambda (lambda clauses (expand-match-lambda (cons '() clauses))) expand-match-lambda match-case (lambda (expr . clauses) `((match-lambda ,@clauses) ,expr)) describe \"describe\" \"~S has not been defined in ~S\" \"bigmatch\" \"getopt\" %print-usage \"trace\" pp \"pretty-print\" pretty-print help \"help\" lexer-next-token \"lex-rt\" random-integer \"srfi/27\" random-real srfi48:help \"srfi/48\" srfi48:format-fixed environment \"env\" null-environment scheme-report-environment interaction-environment ((STKLOS-OBJECT) (MBE) (SRFI-0) (REPL) (REPL-READLINE)) scheme/base ((SCHEME)) %define-here (lambda lst `(begin ,@(map (lambda (symb) `(define ,symb #void)) lst))) _ assv bytevector-append bytevector-copy ceiling char->integer char-ready? char<=? char char>=? char>? complex? denominator even? gcd get-output-bytevector inexact? lcm list-set! min numerator odd? open-input-bytevector open-output-bytevector peek-char read-bytevector string string->utf8 string-copy truncate u8-ready? utf8->string vector-append vector-fill! write-char ((* . *) (+ . +) (- . -) (... . ...) (/ . /) (< . <) (<= . <=) (= . =) (=> . =>) (> . >) (>= . >=) (_ . _) (abs . abs) (and . and) (append . append) (apply . apply) (assoc . assoc) (assq . assq) (assv . assv) (begin . begin) (binary-port? . binary-port?) (boolean=? . boolean=?) (boolean? . boolean?) (bytevector . bytevector) (bytevector-append . bytevector-append) (bytevector-copy . bytevector-copy) (bytevector-copy! . bytevector-copy!) (bytevector-length . bytevector-length) (bytevector-u8-ref . bytevector-u8-ref) (bytevector-u8-set! . bytevector-u8-set!) (bytevector? . bytevector?) (caar . caar) (cadr . cadr) (call-with-current-continuation . call-with-current-continuation) (call-with-port . call-with-port) (call-with-values . call-with-values) (call/cc . call/cc) (car . car) (case . case) (cdar . cdar) (cddr . cddr) (cdr . cdr) (ceiling . ceiling) (char->integer . char->integer) (char-ready? . char-ready?) (char<=? . char<=?) (char . char) (char=? . char=?) (char>=? . char>=?) (char>? . char>?) (char? . char?) (close-input-port . close-input-port) (close-output-port . close-output-port) (close-port . close-port) (complex? . complex?) (cond . cond) (cond-expand . cond-expand) (cons . cons) (current-error-port . current-error-port) (current-input-port . current-input-port) (current-output-port . current-output-port) (define . define) (define-record-type . define-record-type) (define-syntax . define-syntax) (define-values . define-values) (denominator . denominator) (do . do) (dynamic-wind . dynamic-wind) (else . else) (eof-object . eof-object) (eof-object? . eof-object?) (eq? . eq?) (equal? . equal?) (eqv? . eqv?) (error . error) (error-object-irritants . error-object-irritants) (error-object-message . error-object-message) (error-object? . error-object?) (even? . even?) (exact . exact) (exact-integer-sqrt . exact-integer-sqrt) (exact-integer? . exact-integer?) (exact? . exact?) (expt . expt) (features . features) (file-error? . file-error?) (floor . floor) (floor-quotient . floor-quotient) (floor-remainder . floor-remainder) (floor/ . floor/) (flush-output-port . flush-output-port) (for-each . for-each) (gcd . gcd) (get-output-bytevector . get-output-bytevector) (get-output-string . get-output-string) (guard . guard) (if . if) (include . include) (include-ci . include-ci) (inexact . inexact) (inexact? . inexact?) (input-port-open? . input-port-open?) (input-port? . input-port?) (integer->char . integer->char) (integer? . integer?) (lambda . lambda) (lcm . lcm) (length . length) (let . let) (let* . let*) (let*-values . let*-values) (let-syntax . let-syntax) (let-values . let-values) (letrec . letrec) (letrec* . letrec*) (letrec-syntax . letrec-syntax) (list . list) (list->string . list->string) (list->vector . list->vector) (list-copy . list-copy) (list-ref . list-ref) (list-set! . list-set!) (list-tail . list-tail) (list? . list?) (make-bytevector . make-bytevector) (make-list . make-list) (make-parameter . make-parameter) (make-string . make-string) (make-vector . make-vector) (map . map) (max . max) (member . member) (memq . memq) (memv . memv) (min . min) (modulo . modulo) (negative? . negative?) (newline . newline) (not . not) (null? . null?) (number->string . number->string) (number? . number?) (numerator . numerator) (odd? . odd?) (open-input-bytevector . open-input-bytevector) (open-input-string . open-input-string) (open-output-bytevector . open-output-bytevector) (open-output-string . open-output-string) (or . or) (output-port-open? . output-port-open?) (output-port? . output-port?) (pair? . pair?) (parameterize . parameterize) (peek-char . peek-char) (peek-u8 . peek-u8) (port? . port?) (positive? . positive?) (procedure? . procedure?) (quasiquote . quasiquote) (quote . quote) (quotient . quotient) (raise . raise) (raise-continuable . raise-continuable) (rational? . rational?) (rationalize . rationalize) (read-bytevector . read-bytevector) (read-bytevector! . read-bytevector!) (read-char . read-char) (read-error? . read-error?) (read-line . read-line) (read-string . read-string) (read-u8 . read-u8) (real? . real?) (remainder . remainder) (reverse . reverse) (round . round) (set! . set!) (set-car! . set-car!) (set-cdr! . set-cdr!) (square . square) (string . string) (string->list . string->list) (string->number . string->number) (string->symbol . string->symbol) (string->utf8 . string->utf8) (string->vector . string->vector) (string-append . string-append) (string-copy . string-copy) (string-copy! . string-copy!) (string-fill! . string-fill!) (string-for-each . string-for-each) (string-length . string-length) (string-map . string-map) (string-ref . string-ref) (string-set! . string-set!) (string<=? . string<=?) (string . string) (string=? . string=?) (string>=? . string>=?) (string>? . string>?) (string? . string?) (substring . substring) (symbol->string . symbol->string) (symbol=? . symbol=?) (symbol? . symbol?) (syntax-error . syntax-error) (syntax-rules . syntax-rules) (textual-port? . textual-port?) (truncate . truncate) (truncate-quotient . truncate-quotient) (truncate-remainder . truncate-remainder) (truncate/ . truncate/) (u8-ready? . u8-ready?) (unless . unless) (unquote . unquote) (unquote-splicing . unquote-splicing) (utf8->string . utf8->string) (values . values) (vector . vector) (vector->list . vector->list) (vector->string . vector->string) (vector-append . vector-append) (vector-copy . vector-copy) (vector-copy! . vector-copy!) (vector-fill! . vector-fill!) (vector-for-each . vector-for-each) (vector-length . vector-length) (vector-map . vector-map) (vector-ref . vector-ref) (vector-set! . vector-set!) (vector? . vector?) (when . when) (with-exception-handler . with-exception-handler) (write-bytevector . write-bytevector) (write-char . write-char) (write-string . write-string) (write-u8 . write-u8) (zero? . zero?)) \"scheme/base\" scheme/write ((display . display) (write . write) (write-shared . write-shared) (write-simple . write-simple)) \"scheme/write\" ((STKLOS-COMPILER) (STKLOS-OBJECT) (MBE) (SRFI-0) (REPL) (REPL-READLINE)) \"STKLOS_BUILDING\" module-immutable! %before-exit-hook main \"STKLOS_FRAMES\" \" - ...\\nSet shell variable STKLOS_FRAMES to set visible frames\\n\" \" - \" %procedure-name \"<>\" \" @ [~A:~A]\\n\" \"???\" \"**** Error while ~A ~S\\n\" \"\\t Where: in ~A\" \" (near line ~a in file ~s)\" \"\\tReason: ~A\\n\" \"EXIT\\n\" %simple-fatal-exception-handler #:no-init-file #:load #:srfi-176 #:file #:sexpr #:conf-dir #:comp-flags #:prepend-dirs #:append-dirs \"Warning: cannot create configuration directory ~S\\n\" \"stklosrc\" \"loading file\" \"executing command\" \"evaluating\")";
+char* STk_boot_consts = "#(current-input-port original-input-port #:aa caar #:ad cdar #:da cadr #:dd cddr #:aaa caaar #:aad cdaar #:ada cadar #:add cddar #:daa caadr #:dad cdadr #:dda caddr #:ddd cdddr #:aaaa caaaar #:aaad cdaaar #:aada cadaar #:aadd cddaar #:adaa caadar #:adad cdadar #:adda caddar #:addd cdddar #:daaa caaadr #:daad cdaadr #:dada cadadr #:dadd cddadr #:ddaa caaddr #:ddad cdaddr #:ddda cadddr #:dddd cddddr pair? car map apply map* cdr for-each* filter filter-map append append-map append! append-map! generic? parameter? %procedure-plist #:setter key-get setter \"no setter defined for ~S\" error key-set! %set-procedure-plist! set-car! set-cdr! vector-ref vector-set! string-ref string-set! slot-ref slot-set! struct-ref struct-set! \"\" string->symbol \"~a\" format string-append symbol-append define-parameter (lambda (name . args) (if (<= 1 (length args) 2) (let ((tmp (gensym 'param))) `(define ,name (let ((,tmp (make-parameter ,@args))) (%set-parameter-name! ,tmp ',name) ,tmp))) (syntax-error 'define-parameter \"bad number of arguments (must be 2 or 3)\"))) length <= param gensym define let make-parameter %set-parameter-name! quote \"bad number of arguments (must be 2 or 3)\" %syntax-error STKLOS-COMPILER %make-syntax integer? stklos-debug-level \"bad integer\" compiler-known-globals memq register-new-global! for-each register-new-globals! %modules-stack current-module %create-module %module-create %module-restore raise %module-handler current-error-port \"\\x1b;[33m\" display \"\\x1b;[0m\" newline %debug STklos find-module when (lambda args (if (<= (length args) 1) (syntax-error 'when \"bad syntax in ~S\" `(when ,@args)) `(if ,(car args) (begin ,@(cdr args))))) \"bad syntax in ~S\" if begin stklos unless (lambda args (if (<= (length args) 1) (syntax-error 'unless \"bad syntax in ~S\" `(unless ,@args)) `(if (not ,(car args)) (begin ,@(cdr args))))) \"bad syntax in ~S\" not set! (lambda args `(%%set! ,@args)) %%set! %claim-error (lambda (owner . body) (let ((x (gensym))) `(with-handler (lambda (,x) (error ,owner (condition-ref ,x 'message))) ,@body))) with-handler lambda condition-ref message syntax-error (lambda args (if (zero? (length args)) (error 'syntax-error \"needs at least one argument\") `(%syntax-error ,@args))) zero? \"needs at least one argument\" define-syntax (lambda (macro-name syn-rules) (if (or (not (pair? syn-rules)) (not (eq? (car syn-rules) 'syntax-rules))) (error 'define-syntax \"in `~S', bad syntax-rules ~S\" macro-name syn-rules) (let ((ellipsis '...)) (when (or (symbol? (cadr syn-rules)) (keyword? (cadr syn-rules))) (set! ellipsis (cadr syn-rules)) (set! syn-rules (cdr syn-rules))) (let ((keywords (cons macro-name (cadr syn-rules))) (clauses (cddr syn-rules)) (find-clause (symbol-value 'find-clause (find-module 'MBE)))) `(define-macro (,macro-name . args) (%find-macro-clause ',macro-name args ',keywords ',clauses ',ellipsis)))))) syntax-rules \"in `~S', bad syntax-rules ~S\" ... symbol? keyword? find-clause MBE symbol-value define-macro args %find-macro-clause module-symbols library? module-symbols* module? %module-exports module-exports select-module (lambda (name) (let* ((compfile (in-module STKLOS-COMPILER *compiling-file*)) (mod (find-module name #f)) (newmod (or mod (if compfile (%module-create name) (error 'select-module \"module ~s does not exists\" name))))) (when (and mod (not (eq? name 'STklos))) (register-new-globals! (module-symbols mod))) `(begin (%%set-current-module (find-module ',name)) (when-compile (compiler-current-module ,newmod))))) symbol-value* *compiling-file* \"module ~s does not exists\" %%set-current-module when-compile compiler-current-module define-module (lambda (name . body) (let ((oldmod (compiler-current-module)) (newmod (or (find-module name #f) (%module-create name)))) `(with-handler %module-handler (%%set-current-module (%module-create ',name)) (%%when-compile (compiler-current-module ,newmod)) ,@body (%%when-compile (compiler-current-module ,oldmod)) (%%set-current-module ((%%in-scheme '%module-restore))) (values (void) ',name)))) %%when-compile %%in-scheme values void list? only every import \"bad list of symbols ~s in only clause\" #:only \"bad only clause ~s\" except \"bad list of symbols ~s in except clause\" #:except \"bad except clause ~s\" prefix #:prefix \"bad prefix clause ~s\" rename \"bad list of associations ~s in rename clause\" #:rename \"bad rename clause ~s\" %normalize-library-name \"bad import set ~s\" %parse-imports %find-instanciated-module symbol->string require/provide \"module/library ~s does not exist\" %symbol->library-name \"symbol ~s is not in the import set\" filter! remove list-copy absent %syntax? %symbol-link reverse module-name module-imports %module-imports-set! %do-imports (lambda modules (let ((imp (%parse-imports modules))) (for-each (lambda (x) (%grab-file-information (symbol->string (car x)))) imp) (%do-imports (compiler-current-module) (list-copy imp) #t) `(%do-imports (current-module) (list-copy ',imp) #f))) %grab-file-information %%import reverse! %do-exports export \"bad renaming clause ~S\" \"bad exportation `~S'\" %parse-exports assq \"exported symbol ~s was previously renamed as ~S\" %module-exports-set! (lambda symbols (let ((s (%parse-exports symbols))) `(%do-exports (current-module) ',s))) export-syntax (lambda arg `(%%publish-syntax ,@arg)) %%publish-syntax in-module (lambda (mod symb . default) `(apply symbol-value* ',symb (find-module ',mod) ',default)) all-modules module-list %populate-scheme-module SCHEME ((SCHEME)) ((eval . eval) (disassemble . disassemble) (disassemble-expr . disassemble-expr) (%compiler-set-flags . %compiler-set-flags) (%grab-file-information . %grab-file-information) (%compiler-new-label . %compiler-new-label) (%macro-expand . %macro-expand) (compiler-current-module . compiler-current-module) (when-compile . when-compile) (when-load-and-compile . when-load-and-compile) (%syntax-error . %syntax-error) (%compile-time-define . %compile-time-define)) *compiler-port* + - * / fx+ fx- fx* fxquotient = < > >= fx=? fx fx<=? fx>? fx>=? fx= fx< fx<= fx> fx>= cons null? list eq? eqv? equal? %cxr list-ref *inline-table* *inline-symbols* (%set-current-module %%set-current-module %%execute %%execute-handler) *always-inlined* *code-instr* *code-constants* *code-labels* label? NOP this-instr next-instr this-arg1 this-arg2 next-arg1 next-arg2 GOTO RETURN PUSH (IM-FALSE IM-TRUE IM-NIL IM-MINUS1 IM-ZERO IM-ONE IM-VOID) IM-FALSE FALSE-PUSH IM-TRUE TRUE-PUSH IM-NIL NIL-PUSH IM-MINUS1 MINUS1-PUSH IM-ZERO ZERO-PUSH IM-ONE ONE-PUSH IM-VOID VOID-PUSH SMALL-INT INT-PUSH CONSTANT CONSTANT-PUSH DEEP-LOCAL-REF DEEP-LOC-REF-PUSH IN-NOT (IN-NUMEQ IN-NUMDIFF IN-FXEQ IN-FXDIFF IN-NUMLT IN-NUMGT IN-NUMLE IN-NUMGE IN-EQ IN-EQV IN-EQUAL) IN-NUMEQ IN-NUMDIFF IN-FXEQ IN-FXDIFF IN-NUMLT IN-NUMGE IN-NUMGT IN-NUMLE IN-EQ IN-NOT-EQ IN-EQV IN-NOT-EQV IN-EQUAL IN-NOT-EQUAL JUMP-FALSE (IN-NUMEQ IN-NUMLT IN-NUMGT IN-NUMLE IN-NUMGE IN-EQ IN-EQV IN-EQUAL IN-NOT) JUMP-NUMDIFF JUMP-NUMEQ JUMP-NUMGE JUMP-NUMGT JUMP-NUMLE JUMP-NUMLT JUMP-NOT-EQ JUMP-NOT-EQV JUMP-NOT-EQUAL JUMP-TRUE GLOBAL-REF GLOBAL-REF-PUSH PUSH-GLOBAL-REF INVOKE PUSH-GREF-INVOKE TAIL-INVOKE PUSH-GREF-TAIL-INV PREPARE-CALL PUSH-PREPARE-CALL GREF-INVOKE GREF-TAIL-INVOKE (LOCAL-REF0 LOCAL-REF1 LOCAL-REF2 LOCAL-REF3 LOCAL-REF4) LOCAL-REF0 LOCAL-REF0-PUSH LOCAL-REF1 LOCAL-REF1-PUSH LOCAL-REF2 LOCAL-REF2-PUSH LOCAL-REF3 LOCAL-REF3-PUSH LOCAL-REF4 LOCAL-REF4-PUSH peephole ((NOP 0) (IM-FALSE 0) (IM-TRUE 0) (IM-NIL 0) (IM-MINUS1 0) (IM-ZERO 0) (IM-ONE 0) (IM-VOID 0) (SMALL-INT 1) (CONSTANT 1) (GLOBAL-REF 1) (UGLOBAL-REF 1) (LOCAL-REF0 0) (LOCAL-REF1 0) (LOCAL-REF2 0) (LOCAL-REF3 0) (LOCAL-REF4 0) (LOCAL-REF 1) (DEEP-LOCAL-REF 1) (GLOBAL-SET 1) (UGLOBAL-SET 1) (LOCAL-SET0 0) (LOCAL-SET1 0) (LOCAL-SET2 0) (LOCAL-SET3 0) (LOCAL-SET4 0) (LOCAL-SET 1) (DEEP-LOCAL-SET 1) (GOTO 1) (JUMP-FALSE 1) (JUMP-TRUE 1) (DEFINE-SYMBOL 1) (POP 0) (PUSH 0) (DBG-VM 1) (CREATE-CLOSURE 2) (RETURN 0) (PREPARE-CALL 0) (INVOKE 1) (TAIL-INVOKE 1) (ENTER-LET-STAR 1) (ENTER-LET 1) (ENTER-TAIL-LET-STAR 1) (ENTER-TAIL-LET 1) (LEAVE-LET 0) (PUSH-HANDLER 1) (POP-HANDLER 0) (END-OF-CODE 0) (IN-ADD2 0) (IN-SUB2 0) (IN-MUL2 0) (IN-DIV2 0) (IN-NUMEQ 0) (IN-NUMLT 0) (IN-NUMGT 0) (IN-NUMLE 0) (IN-NUMGE 0) (IN-INCR 0) (IN-DECR 0) (IN-CONS 0) (IN-NULLP 0) (IN-CAR 0) (IN-CDR 0) (IN-LIST 1) (IN-NOT 0) (IN-VREF 0) (IN-VSET 0) (IN-SREF 0) (IN-SSET 0) (IN-EQ 0) (IN-EQV 0) (IN-EQUAL 0) (IN-APPLY 2) (IN-CXR 1) (SET-CUR-MOD 0) (DOCSTRG 1) (PROCNAME 1) (FALSE-PUSH 0) (TRUE-PUSH 0) (NIL-PUSH 0) (MINUS1-PUSH 0) (ZERO-PUSH 0) (ONE-PUSH 0) (VOID-PUSH 0) (INT-PUSH 1) (CONSTANT-PUSH 1) (GREF-INVOKE 2) (UGREF-INVOKE 2) (IN-NUMDIFF 0) (IN-NOT-EQ 0) (IN-NOT-EQV 0) (IN-NOT-EQUAL 0) (JUMP-NUMDIFF 1) (JUMP-NUMEQ 1) (JUMP-NUMLT 1) (JUMP-NUMLE 1) (JUMP-NUMGT 1) (JUMP-NUMGE 1) (JUMP-NOT-EQ 1) (JUMP-NOT-EQV 1) (JUMP-NOT-EQUAL 1) (LOCAL-REF0-PUSH 0) (LOCAL-REF1-PUSH 0) (LOCAL-REF2-PUSH 0) (LOCAL-REF3-PUSH 0) (LOCAL-REF4-PUSH 0) (GLOBAL-REF-PUSH 1) (UGLOBAL-REF-PUSH 1) (GREF-TAIL-INVOKE 2) (UGREF-TAIL-INVOKE 2) (PUSH-PREPARE-CALL 0) (PUSH-GLOBAL-REF 1) (PUSH-UGLOBAL-REF 1) (PUSH-GREF-INVOKE 2) (PUSH-UGREF-INVOKE 2) (PUSH-GREF-TAIL-INV 2) (PUSH-UGREF-TAIL-INV 2) (DEEP-LOC-REF-PUSH 1) (UNUSED-3 0) (UNUSED-4 0) (UNUSED-5 0) (UNUSED-6 0) (UNUSED-7 0) (UNUSED-8 0) (UNUSED-9 0) (UNUSED-10 0) (UNUSED-11 0) (UNUSED-12 0) (UNUSED-13 0) (UNUSED-14 0) (UNUSED-15 0) (UNUSED-16 0) (UNUSED-17 0) (UNUSED-18 0) (UNUSED-19 0) (IN-SINT-ADD2 1) (IN-SINT-SUB2 1) (IN-SINT-MUL2 1) (IN-SINT-DIV2 1) (UNUSED-20 0) (UNUSED-21 0) (UNUSED-22 0) (UNUSED-23 0) (UNUSED-24 0) (UNUSED-25 0) (UNUSED-26 0) (UNUSED-27 0) (UNUSED-28 0) (CALL-LOCATION 1) (DEEP-LOC-REF-FAR 1) (DEEP-LOC-SET-FAR 1) (CREATE-CLOSURE-FAR 2) (PUSH-HANDLER-FAR 1) (IN-FXADD2 0) (IN-FXSUB2 0) (IN-FXMUL2 0) (IN-FXDIV2 0) (IN-SINT-FXADD2 1) (IN-SINT-FXSUB2 1) (IN-SINT-FXMUL2 1) (IN-SINT-FXDIV2 1) (IN-FXEQ 0) (IN-FXLT 0) (IN-FXGT 0) (IN-FXLE 0) (IN-FXGE 0) (IN-FXDIFF 0) (SOURCE 1) (FORMALS 1) (INSCHEME 0)) INSTRUCTION-SET \"non existent opcode ~S\" panic info-opcode (GOTO JUMP-FALSE JUMP-TRUE JUMP-NUMDIFF JUMP-NUMGE JUMP-NUMGT JUMP-NUMGE JUMP-NUMLT JUMP-NUMLE JUMP-NOT-EQ JUMP-NOT-EQV JUMP-NOT-EQUAL CREATE-CLOSURE CREATE-CLOSURE-FAR PUSH-HANDLER PUSH-HANDLER-FAR) use-address? string-upcase string-length #\\space make-string pretty-mnemonic \"Cannot decode ~S opcode\" find-instruction-infos CREATE-CLOSURE CREATE-CLOSURE-FAR PUSH-HANDLER PUSH-HANDLER-FAR \"No FAR version of instruction ~S\" find-far-codeop make-vector small-integer-constant? (CREATE-CLOSURE-FAR PUSH-HANDLER-FAR) memv fetch-constant \"Instr. using a big constant as 2nd operand ~S\" \"Instruction with more than 2 parameters ~S\" assemble \"~A~A~A\" quotient remainder \"\\t;; ==> ~A\" vector-length \"\\n~A: ~A\" \" ~A\" \" ~S ~S\" \"cannot disassemble instruction (~S)\" \"\\n~A:\\n\" disassemble-code current-output-port \"too many optional parameters: ~a\" %procedure-code disassemble \"cannot disassemble ~S (not a closure with bytecode)\" compile END-OF-CODE emit vector-copy \"\\nConstants:\\n\" fprintf \"~A: ~W\\n\" dynamic-wind disassemble-expr \"*** PANIC *** \" getcwd string-position substring %path-without-cwd \"\" \"~A: \" %epair? \"~A:~A: \" %epair-file %epair-line %port-file-fd \"~A:~A: \" port-file-name port-current-line \"\" \"~AError: ~A~A\\n\" compiler-error \"\" \"~A: \" \"~A:~A: \" \"\" \"~Awarning: ~A~A\\n\" \"**** Warning;\\n~A~A\\n\" compiler-warning unquote \"used outside of a quasiquote context\" unquote-splicing \"used outside of a quasiquote context\" string? \"bad parameters ~S\" \"bad parameters ~S\" *file-module-list* file-module-list-reset! add-file-module-list! %syntax-source file-module-list-expanders #:prepend G35 #:version version #:globals #:macros clock compiler:warn-use-undefined-postpone compile-file \"prepend should be a list: ~S\" %include-file \"#!/usr/bin/env stklos\\n\" \"; A -*- Scheme -*- generated file *DO NOT EDIT**\\n\" \"STklos ~S\\n\" compiler:show-assembly-code \"\\n#|\\n\" \"\\n~S\\n|#\\n\" \"#~S\\n\" %dump-code close-output-port compiler-show-undefined-symbols interactive-port? compiler:time-display \"Compilation time ~S ms\\n\" round exact dirname \"stk-tmp.\" make-path create-temp-file file-exists? delete-file rename-file call-with-values ((compile-file . compile-file)) ((define-parameter . define-parameter) (compiler:time-display . compiler:time-display) (compiler:gen-line-number . compiler:gen-line-number) (compiler:warn-use-undefined . compiler:warn-use-undefined) (compiler:warn-use-undefined-postpone . compiler:warn-use-undefined-postpone) (compiler:show-assembly-code . compiler:show-assembly-code) (compiler:keep-formals . compiler:keep-formals) (compiler:keep-source . compiler:keep-source) (compiler:inline-common-functions . compiler:inline-common-functions) (compiler:unroll-iterations . compiler:unroll-iterations)) compiler:gen-line-number compiler:warn-use-undefined compiler:keep-formals compiler:keep-source fixnum? positive? compiler:unroll-iterations \"must be a positive fixnum. It was ~s\" compiler:inline-common-functions \"Fatal error: ~a\\nABORT\\n\" condition-message eprintf emergency-exit (#\\+ #\\-) #\\+ char=? line-info time-display keep-formals compiler:generate-signature keep-source inline-usuals show-instructions \"bad boolean flag ~s\" \"=\" string-split string->number unroll-iterations \"bad value for unroll-iteration ~s\" \"bad flag name ~s\" \"bad valued flag ~s\" \",\" %compiler-set-flags scope (locals mlocals parent) make-struct-type make-struct make-scope struct? struct-is-a? scope? scope-locals %fast-struct-ref scope-mlocals scope-parent %fast-struct-set! find-symbol-in-env \"***SCOPE*** ~S\\n\" \" ==> locals= ~S mlocals= ~S parent =~S\" %debug-scope find-syntax-in-env %macro-expand quasiquote %syntax-expander \"bad module parameter ~s\" new-label %compiler-new-label emit-label expt exact? compile-constant \"bad usage in ~S\" compile-quote *forward-globals* symbol-bound? known-var? \"reference to undefined symbol ~S\" compiler-warn-undef verify-global define->lambda \"ill formed definition ~S\" \"bad definition\" DEFINE-SYMBOL \"bad variable name ~S\" \"internal define forbidden here ~S\" compile-define GLOBAL-SET LOCAL-SET0 LOCAL-SET1 LOCAL-SET2 LOCAL-SET3 LOCAL-SET4 LOCAL-REF LOCAL-SET DEEP-LOCAL-SET DEEP-LOC-REF-FAR DEEP-LOC-SET-FAR compile-access compile-reference \"~S is a bad symbol\" \"bad assignment syntax in ~S\" compile-set! \"bad syntax in ~S\" compile-if extended-lambda->lambda eval %symbol-define \"bad variable name ~S\" \"internal define-macro forbidden here ~S\" compile-define-macro compile-and compile-or compile-begin compute-arity extend-env extract-doc-and-name \"body is empty\" compile-body DOCSTRG PROCNAME keyword->string FORMALS SOURCE compile-user-lambda ext-lambda-key-get and or 'lambda make-keyword \"too many optional parameters: ~a\" let* build-let* \"illegal ~a parameter: ~a\" \"optional\" \"keyword\" (#:optional #:key #:rest) \"duplicate parameter ~S\" \"bad class name ~S\" \"bad procedure parameter ~S\" last-pair #:rest #:optional #:key \"illegal lambda list ending with ~a\" \"rest parameter must be a single symbol\" parse-parameter-list rewrite-params-and-body method \"bad definition ~S\" compile-lambda compile-args compile-var-args CALL-LOCATION %maybe-generate-line-information generate-PREPARE-CALL compile-normal-call assoc can-be-inlined? \"1 argument required (~A provided)\" \"2 arguments required (~A provided)\" \"3 arguments required (~A provided)\" SET-CUR-MOD \"1 arg. only (~S)\" %%execute-handler EXEC-HANDLER number? IN-INCR IN-SINT-ADD2 IN-ADD2 \"needs at least one argument\" IN-SINT-SUB2 IN-DECR IN-SUB2 IN-SINT-MUL2 IN-MUL2 \"needs at least one argument\" IN-SINT-DIV2 IN-DIV2 (fx+ fx- fx* fxquotient) (fx+ fx*) IN-SINT-FXADD2 IN-SINT-FXMUL2 IN-SINT-FXSUB2 IN-SINT-FXDIV2 IN-FXADD2 IN-FXSUB2 IN-FXMUL2 IN-FXDIV2 (= < > <= >=) O \"needs at least one argument\" (fx=? fx fx>? fx<=? fx>=? fx= fx< fx> fx<= fx>=) \"needs at least one argument\" (fx=? fx=) (fx fx<) IN-FXLT (fx>? fx>) IN-FXGT (fx<=? fx<=) IN-FXLE (fx>=? fx>=) IN-FXGE IN-CONS IN-CAR IN-CDR IN-NULLP IN-LIST IN-VREF IN-VSET IN-SREF IN-SSET (caar cdar cadr cddr caaar cdaar cadar cddar caadr cdadr caddr cdddr caaaar cdaaar cadaar cddaar caadar cdadar caddar cdddar caaadr cdaadr cadadr cddadr caaddr cdaddr cadddr cddddr) string->list list->string string->keyword IN-CXR \"unimplemented inline primitive ~S\" compile-primitive-call negative? ENTER-TAIL-LET ENTER-LET LEAVE-LET \"bad number of parameters ~S\" compile-lambda-call |λ| compile-call \"duplicate binding ~S\" \"malformed binding ~S\" valid-let-bindings? letrec \"ill formed letrec ~S\" compile-letrec \"ill formed named let ~S\" compile-named-let \"ill formed let ~S\" compile-let \"ill formed let* ~S\" ENTER-TAIL-LET-STAR ENTER-LET-STAR compile-let* cond \"invalid clause ~S\" else \"else not in last clause ~S\" => rewrite-cond-clauses \"bad '=>' clause syntax ~S\" compile-cond ok case \"duplicate case value ~S in ~S\" \"ill formed case clause ~S\" \"invalid clause syntax in ~S\" \"ill formed else clause ~S\" \"ill formed clause ~S\" rewrite-case-clauses \"no key given\" compile-case do \"bad binding ~S\" rewrite-do \"bad syntax\" compile-do 'quasiquote backquotify 'unquote 'unquote-splicing vector? list->vector vector->list \"bad syntax\" compile-quasiquote POP-HANDLER \"bad syntax\" compile-with-handler open-input-file eof-object? %read close-port include \"bad include directive ~S\" compile-include include-ci \"bad include directive ~S\" read-case-sensitive compile-include-ci INSCHEME \"expected one argument\" compile-in-scheme %let-syntax \"ill formed %let-syntax ~S\" \"ill formed binding ~S\" compile-%let-syntax %file-information remove-file #:nature source data %library-prefix load-path find-path unknown find-file-information member import-file-information boolean? compile-require \"*** Exception on when-compile form of ~S\\n\" compile-when-compile (lambda body `(begin (%%when-compile ,@body) (void))) when-load-and-compile (lambda body `(begin (%%when-compile ,@body) ,@body (void))) %%label \"bad usage ~S\" compile-%%label %%goto \"bad usage ~S\" compile-%%goto compile-%%source-pos (lambda |λ|) (let %let) %%require %%include %%include-ci %%source-pos %execute %compile-time-define (lambda symbs `(when-compile ,@(map (lambda (x) `(define ,x #void)) symbs))) ((STKLOS-COMPILER)) ((with-input-from-file . with-input-from-file) (with-output-to-file . with-output-to-file) (with-error-to-file . with-error-to-file) (with-input-from-string . with-input-from-string) (with-output-to-string . with-output-to-string) (with-input-from-port . with-input-from-port) (with-output-to-port . with-output-to-port) (with-error-to-port . with-error-to-port) (%call-with . %call-with) (call-with-input-file . call-with-input-file) (call-with-output-file . call-with-output-file) (rationalize . rationalize) (call-with-values . call-with-values)) open-file &i/o-filename-error location \"cannot open file ~S\" backtrace %vm-backtrace filename make-condition %make-with-file with-input-from-file \"r\" with-output-to-file \"w\" with-error-to-file \"w\" open-input-string with-input-from-string open-output-string get-output-string with-output-to-string %make-with-port \"r\" with-input-from-port \"w\" with-output-to-port \"w\" with-error-to-port %call-with call-with-input-file open-output-file call-with-output-file rationalize \"bad rational ~S\" floor 0.0 rational? %call-for-values %use-utf8? string-blit! string-titlecase string-titlecase! \"bad string ~S\" \" \\t\\n\" %string-use-utf8? \"bad offset ~S\" string-mutable? \"changing the constant string ~S is not allowed\" \"bad starting index ~S\" \"bad ending index ~S\" char-alphabetic? char-upcase char-downcase \"bad starting index ~S\" \"bad ending index ~S\" ((call/cc . call/cc) (call-with-current-continuation . call-with-current-continuation) (dynamic-wind . dynamic-wind)) %make-continuation %fresh-continuation? %restore-continuation %call/cc call/cc %thread-dynwind-stack %thread-dynwind-stack-set! procedure? \"bad procedure ~S\" call-with-current-continuation ((define-struct . define-struct)) define-struct (lambda (name . slots) (define (compute-offset slot slots) (let ((sublist (memq slot slots))) (- (length slots) (length sublist)))) (let* ((pred (string->symbol (format \"~a?\" name))) (arg (gensym)) (val (gensym))) `(begin (define ,name (make-struct-type ',name #f ',slots)) (define (,(string->symbol (format \"make-~a\" name)) unquote arg) (apply make-struct ,name ,arg)) (define (,pred ,arg) (and (struct? ,arg) (struct-is-a? ,arg ,name))) ,@(map (lambda (x) (let ((fname (string->symbol (format \"~a-~a\" name x)))) `(define ,fname (lambda (,arg) (%fast-struct-ref ,arg ,name ',fname ,(compute-offset x slots)))))) slots) ,@(map (lambda (x) (let ((fname (string->symbol (format \"~a-~a\" name x)))) `(set! (setter ,fname) (lambda (,arg ,val) (%fast-struct-set! ,arg ,name ',fname ,(compute-offset x slots) ,val))))) slots) (values (void) ',name)))) \"~a?\" \"make-~a\" \"~a-~a\" \"~a-~a\" ((read-chars . read-chars) (read-chars! . read-chars!) (display-shared . display-shared) (gensym . gensym) (macro-expand . macro-expand) (macro-expand* . macro-expand*) (remove . remove) (remove! . remove!) (delete . delete) (delete! . delete!) (every . every) (any . any) (call-with-input-string . call-with-input-string) (call-with-output-string . call-with-output-string) (open-input-virtual . open-input-virtual) (open-output-virtual . open-output-virtual) (read-from-string . read-from-string) (eval-from-string . eval-from-string) (command-line . command-line) (program-name . program-name) (create-directories . create-directories) (ensure-directories-exist . ensure-directories-exist) (posix-error? . posix-error?) (posix-error-name . posix-error-name) (posix-error-message . posix-error-message) (posix-error-errno . posix-error-errno) (posix-error-procedure . posix-error-procedure) (posix-error-arguments . posix-error-arguments) (make-hash-table . make-hash-table) (hash-table->alist . hash-table->alist) (alist->hash-table . alist->hash-table) (hash-table-update! . hash-table-update!) (hash-table-update!/default . hash-table-update!/default) (hash-table-keys . hash-table-keys) (hash-table-values . hash-table-values) (hash-table-fold . hash-table-fold) (hash-table-merge! . hash-table-merge!) (hash-table-copy . hash-table-copy) (fluid-let . fluid-let) (time . time) (tagbody . tagbody) (dotimes . dotimes) (repeat . repeat) (while . while) (until . until) (call/ec . call/ec) (base64-encode-string . base64-encode-string) (base64-decode-string . base64-decode-string) (md5sum-file . md5sum-file) (ansi-color . ansi-color) (ansi-color-protect . ansi-color-protect) (do-color . do-color) (port->string . port->string) (port->sexp-list . port->sexp-list) (port->string-list . port->string-list) (print . print) (printerr . printerr) (eprintf . eprintf) (printf . printf) (fprintf . fprintf) (declare-new-error . declare-new-error) (exec . exec) (exec-list . exec-list) (apropos . apropos) (die . die) (decompose-file-name . decompose-file-name) (dirname . dirname) (basename . basename) (file-separator . file-separator) (make-path . make-path) (file-suffix . file-suffix) (file-prefix . file-prefix) (port-idle-register! . port-idle-register!) (port-idle-unregister! . port-idle-unregister!) (port-idle-reset! . port-idle-reset!) (chmod . chmod) (with-mutex . with-mutex) (error-object-location . error-object-location) (%push-id . %push-id) (%stable-version? . %stable-version?) (define-constant . define-constant) (void? . void?) (default-browser . default-browser) (open-in-browser . open-in-browser) (manual . manual) (man . man) (receive . receive) (case-lambda . case-lambda) (radians->degrees . radians->degrees) (degrees->radians . degrees->radians) (%define-condition-type-accessors . %define-condition-type-accessors) (message-condition? . message-condition?) (condition-message . condition-message) (serious-condition? . serious-condition?) (error? . error?) (error-message? . error-message?) (error-location . error-location) (error-message . error-message) (read-with-shared-structure . read-with-shared-structure) (read/ss . read/ss) (write-with-shared-structure . write-with-shared-structure) (write/ss . write/ss) (parameterize . parameterize) (require-extension . require-extension) (string->keyword . string->keyword) (get-environment-variable . get-environment-variable) (get-environment-variables . get-environment-variables) (implementation-name . implementation-name) (implementation-version . implementation-version) (cpu-architecture . cpu-architecture) (machine-name . machine-name) (os-name . os-name) (os-version . os-version) (fx-width . fx-width) (fx-greatest . fx-greatest) (fx-least . fx-least) (assume . assume) (version-alist . version-alist) (port-has-port-position? . port-has-port-position?) (port-position . port-position) (port-has-set-port-position!? . port-has-set-port-position!?) (set-port-position! . set-port-position!) (make-i/o-invalid-position-error . make-i/o-invalid-position-error) (i/o-invalid-position-error? . i/o-invalid-position-error?) (command-name . command-name) (command-args . command-args) (argc . argc) (script-file . script-file) (script-directory . script-directory) (make-nan . make-nan)) read-bytes read-chars read-bytes! read-chars! display-shared \"G\" \"bad gensym prefix ~S\" number->string string->uninterned-symbol macro-expand macro-expand* remove! delete delete! \"bad procedure\" any \"bad procedure\" call-with-input-string call-with-output-string #:read-char #:ready? #:eof? #:close vector %open-input-virtual open-input-virtual #:write-char #:write-string #:flush %open-output-virtual open-output-virtual read read-from-string eval-from-string *%system-state-plist* #:script-file \"\" \"\" \"\" #:program-name \"\" #:argv command-line \"bad command line ~S\" program-name file-is-directory? create-directories create-directory ensure-directories-exist condition? &posix-error condition-has-type? posix-error? \"expected a posix-error condition\" %posix-error-condition-ref errname posix-error-name r7rs-msg posix-error-message errno posix-error-errno posix-error-procedure r7rs-irritants posix-error-arguments hash-table-hash %make-hash-table make-hash-table hash-table-map hash-table->alist hash-table-exists? hash-table-set! alist->hash-table hash-table-ref hash-table-update! hash-table-ref/default hash-table-update!/default hash-table-keys hash-table-values hash-table-for-each hash-table-fold hash-table-merge! hash-table-equivalence-function hash-table-hash-function hash-table-copy fluid-let (lambda (bindings . body) (let* ((vars (map car bindings)) (vals (map cadr bindings)) (tmps (map (lambda (x) (gensym)) vars))) `(let ,(map list tmps vars) (dynamic-wind (lambda () ,@(map (lambda (x y) `(set! ,x ,y)) vars vals)) (lambda () ,@body) (lambda () ,@(map (lambda (x y) `(set! ,x ,y)) vars tmps)))))) time (lambda args (let ((tmp1 (gensym)) (tmp2 (gensym))) `(let* ((,tmp1 (clock)) (,tmp2 (begin ,@args))) (format (current-error-port) \"Elapsed time: ~S ms\\n\" (- (clock) ,tmp1)) ,tmp2))) \"Elapsed time: ~S ms\\n\" tagbody (lambda body (let ((tags (map (lambda (x) (cons x (%compiler-new-label))) (filter keyword? body)))) (define (replace code) (if (pair? code) (if (and (eq? (car code) '->) (= (length code) 2)) (let ((t (assq (cadr code) tags))) (if t `(%%goto ,(cdr t)) code)) (map replace code)) code)) (define (verify code) (if (pair? code) (cond ((and (eq? (car code) '->) (= (length code) 2)) (error 'tagbody \"destination label ~S not defined\\n\" (cadr code))) ((eq? (car code) 'tagbody) #void) (else (map verify code))))) (let ((new-body (map (lambda (x) (if (keyword? x) `(%%label ,(cdr (assq x tags))) (replace x))) body))) (verify new-body) `(begin ,@new-body)))) -> \"destination label ~S not defined\\n\" dotimes (lambda (bindings . body) (apply (lambda (var count . result) (let* ((result (if (null? result) (list '(void)) result)) (limit (if (number? count) count (gensym))) (head (if (number? count) '(begin) `(let ((,limit ,count))))) (plus (if (fixnum? count) 'fx+ '+)) (ge (if (fixnum? count) 'fx>= '>=))) `(,@head (do ((,var 0 (,plus ,var 1))) ((,ge ,var ,limit) ,@result) ,@body)))) bindings)) (void) (begin) repeat (lambda (count . body) (define (%repeat n body use-fx?) (let ((minus (if use-fx? 'fx- '-)) (gt (if use-fx? 'fx> '>))) `(tagbody #:top (when (,gt ,n 0) (set! ,n (,minus ,n 1)) ,@body (-> #:top))))) (define (%multiply-list L k) (cond ((fx=? k 0) '()) ((fx=? k 1) (list-copy L)) (else (append (list-copy L) (%multiply-list L (fx- k 1)))))) (let* ((it (compiler:unroll-iterations)) (inside (%multiply-list body it)) (c (gensym)) (q (gensym)) (r (gensym))) (if (fixnum? count) (if (and (= it 1) (positive? count)) `(let ((,c ,count)) ,(%repeat c body #t)) (let ((valq (quotient count it)) (valr (remainder count it))) `(begin ,(if (positive? valq) `(let ((,q ,valq)) ,(%repeat q inside #t)) `(void)) ,(if (positive? valr) `(let ((,r ,valr)) ,(%repeat r body #t)) `(void))))) (if (= it 1) `(let ((,c ,count)) ,(%repeat c body #f)) `(let* ((,c ,count) (,q (quotient ,c ,it)) (,r (remainder ,c ,it))) ,(%repeat q inside #f) ,(%repeat r body #f)))))) #:top while (lambda (test . body) `(tagbody #:top (when ,test (begin ,@body (-> #:top))))) until (lambda (test . body) `(tagbody #:top (unless ,test (begin ,@body (-> #:top))))) \"call/ec\" call/ec base64-encode-string base64-decode-string \"bad string ~s\" base64-encode base64-decode \"r\" md5sum close-input-port \"cannot read file ~s\" md5sum-file ansi-color ansi-color-protect \"\\x1b;[\" \"m\" ((normal . \"0\") (bold . \"1\") (no-bold . \"21\") (italic . \"2\") (no-italic . \"22\") (underline . \"4\") (no-underline . \"24\") (blink . \"5\") (no-blink . \"25\") (reverse . \"7\") (no-reverse . \"27\") (black . \"30\") (bg-black . \"40\") (red . \"31\") (bg-red . \"41\") (green . \"32\") (bg-green . \"42\") (yellow . \"33\") (bg-yellow . \"43\") (blue . \"34\") (bg-blue . \"44\") (magenta . \"35\") (bg-magenta . \"45\") (cyan . \"36\") (bg-cyan . \"46\") (white . \"37\") (bg-white . \"47\")) \"\" \"\\x1b;[\" \"m\" \"\" \"\" \";\" \"38;5;~a\" \"48;5;~a\" \";\" \"bad command ~S\" \"TERM\" getenv \"\" #:interactive regexp-match (\"rxvt\" \"xterm\" \"xterm-color\" \"linux\" \"cygwin\" \"cons25\") \"\" do-color input-port? port->list \"bad port ~S\" %port->list \"bad port ~S\" copy-port port->string port->sexp-list read-line port->string-list print printerr flush-output-port printf declare-new-error (lambda (name) (let ((cond-name (string->symbol (format \"&~a\" name))) (predicate (string->symbol (format \"&~a?\" name))) (args (gensym))) `(begin (define-condition-type ,cond-name &error-message ,predicate) (define (,name unquote args) (if (and (not (null? ,args)) (symbol? (car ,args))) (apply signal-error ,cond-name ,args) (apply signal-error ,cond-name ',name ,args)))))) \"&~a\" \"&~a?\" define-condition-type &error-message signal-error \"| \" exec \"| \" exec-list string apropos \"bad module ~S\" sort string-find? \"**** ~A\\n**** EXIT\\n\" exit die running-os cygwin-windows posixify-file-name #\\/ \"/\" \".\" \"/\" decompose-file-name \"^(.*)/(.+)$\" \"\\\\1\" regexp-replace \"\" string=? \"/\" \".\" \"^(.*)/(.*)$\" \"\\\\2\" basename \"/\" \".\" \"/\" \"^(.*)/(.+)$\" \"\\\\1\" \"\" \"/\" \".\" \"^(.*)/(.*)$\" \"\\\\2\" (unix cygwin-windows android) windows #\\\\ #\\? file-separator \"~A~A~A\" #\\. file-suffix file-prefix port-idle-register! \"bad procedure ~S\" %port-idle port-idle-unregister! \"bad procedure ~S\" port-idle-reset! expand-file-name %chmod bit-or write execute chmod \"bad option ~S\" \"bad option ~S\" mutex-lock! mutex-unlock! with-mutex error-object? \"bad error object: ~S\" error-object-location define-constant (lambda args (define (rewrite l) (if (<= (length l) 1) (error \"bad constant definition\")) (let ((bind (car l)) (body (cdr l))) (if (pair? bind) (rewrite `(,(car bind) (lambda ,(cdr bind) ,@body))) l))) (let ((args (rewrite args))) (if (= (length args) 2) `(begin (define ,@args) (symbol-immutable! ',(car args))) (error \"bad constant definition ~S\" `(define-constant ,@args))))) \"bad constant definition\" symbol-immutable! \"bad constant definition ~S\" void? real? \"bad real number ~S\" 3.14159265358979 radians->degrees \"bad real number ~S\" 3.14159265358979 degrees->radians \"STKLOS_BROWSER\" \"BROWSER\" os-name \"Darwin\" \"open\" \"xdg-open\" default-browser \"bad browser name ~s\" \"~a '~a'\" \"Running command ~s\\n\" system open-in-browser #:htmldir install-path \"stklos-ref.html\" \"~a\" \"file://\" \"https://stklos.net/Doc/HTML/stklos-ref.html\" \"#P_\" manual man %stable-version? \"stable\" %stklos-git #:commit \"unstable -- ~a\" \"unstable\" %push-id receive (lambda (vars producer . body) `(call-with-values (lambda () ,producer) (lambda ,vars ,@body))) case-lambda (lambda clauses (let ((len (gensym)) (args (gensym)) (compute-arity (in-module STKLOS-COMPILER compute-arity))) `(lambda ,args (let ((,len (length ,args))) (cond ,@(map (lambda (x) (unless (>= (length x) 2) (error 'case-lambda \"bad clause ~S\" x)) (let* ((formals (car x)) (body (cdr x)) (arity (compute-arity formals))) (cond ((positive? arity) `((= ,len ,arity) (apply (lambda ,formals ,@body) ,args))) ((zero? arity) `((= ,len ,arity) ,@body)) (else `((>= ,len ,(- (- arity) 1)) (apply (lambda ,formals ,@body) ,args)))))) clauses) (else (error 'case-lambda \"no matching clause in list ~S for ~S\" ',(map car clauses) ,args))))))) \"bad clause ~S\" \"no matching clause in list ~S for ~S\" %define-condition-type-accessors (lambda (name supertype predicate . slots) (let ((obj (gensym))) `(begin (define (,predicate ,obj) (and (condition? ,obj) (condition-has-type? ,obj ,name))) ,@(map (lambda (x) `(define (,(cadr x) ,obj) (unless (,predicate ,obj) (error ',(cadr x) \"bad type for condition ~S\" ,obj)) (condition-ref ,obj ',(car x)))) slots)))) \"bad type for condition ~S\" &message message-condition? &serious serious-condition? &error error? error-message? error-location error-message read-with-shared-structure write* write-with-shared-structure read/ss write/ss parameterize (lambda (bindings . body) (let ((tmp1 (map (lambda (_) (gensym)) bindings)) (tmp2 (map (lambda (_) (gensym)) bindings))) `(let (,@(map (lambda (x y) (list y (cadr x))) bindings tmp1) ,@(map (lambda (x y) (list y (list (car x)))) bindings tmp2)) (dynamic-wind (lambda () ,@(map (lambda (x y) `(,(car x) ,y)) bindings tmp1)) (lambda () ,@body) (lambda () ,@(map (lambda (x y) `(,(car x) ,y)) bindings tmp2)))))) require-extension (lambda args (%find-macro-clause 'require-extension args '(require-extension srfi) '(((_ \"internal\" (srfi id ...)) (begin (require-feature id) ...)) ((_ \"internal\" (x ...)) (import (x ...))) ((_ \"internal\" id) (cond-expand (id #void) (else (error \"cannot require extension named '~s'\" 'id)))) ((_ clause ...) (begin (require-extension \"internal\" clause) ...))) '...)) (require-extension srfi) (((_ \"internal\" (srfi id ...)) (begin (require-feature id) ...)) ((_ \"internal\" (x ...)) (import (x ...))) ((_ \"internal\" id) (cond-expand (id #void) (else (error \"cannot require extension named '~s'\" 'id)))) ((_ clause ...) (begin (require-extension \"internal\" clause) ...))) \"bad string ~S\" get-environment-variable get-environment-variables \"STklos\" implementation-name implementation-version %uname cpu-architecture machine-name \" \" os-version fixnum-width fx-width greatest-fixnum fx-greatest least-fixnum fx-least assume (lambda (expr . args) (if (positive? (stklos-debug-level)) (let* ((efile (and (%epair? expr) (%epair-file expr))) (eline (and (%epair? expr) (%epair-line expr))) (fmt (string-append (if efile (format \"in ~A:~A, \" efile eline) \"\") \"invalid assumption:\"))) `(or ,expr (error ,fmt ',expr ,@args))) #void)) \"in ~A:~A, \" \"\" \"invalid assumption:\" \"srfi-\" %stklos-configure features #:use-utf8 command \"stklos\" scheme.id languages scheme r5rs r7rs encodings (utf-8) threads %thread-system install-dir website \"https://stklos.net\" scheme.features scheme.path scheme.srfi scheme.srfi.count build.configure #:configure build.git.tag #:tag build.git.branch #:branch build.git.commit build.git.modified #:modified c.version #:c-version c.compile #:c-compile c.link #:c-link c.type-bits #:c-type-bits c.library.compile #:shlib-compile c.library.link #:shlib-link c.library.extension #:shlib-suffix stklos.system-libs #:system stklos.compiled-libs #:compiled os.uname os.env.LANG \"LANG\" \"\" os.env.TERM \"TERM\" \"\" version-alist port? port-has-port-position? \"Not a port: ~A\" port-current-position port-position port-has-set-port-position!? \"Not a port: ~A\" output-port? flush port-seek set-port-position! &i/o-bad-parameter parameter make-i/o-invalid-position-error obj i/o-invalid-position-error? \"\" *load-suffixes* command-name command-args argc \"\" \"\" script-file \"\" \"\" \"/\" script-directory %make-nan make-nan ((regexp-replace . regexp-replace) (regexp-replace-all . regexp-replace-all)) regexp-replace-all \"\\\\\\\\[0-9]\" regexp-match-positions \"cannot match \\\\~A in model\" ((run-process . run-process) (process-kill . process-kill) (process-stop . process-stop) (process-continue . process-continue)) \"value expected after keyword ~S\" #:input #:output #:error #:wait #:fork #:args %run-process run-process SIGTERM process-send-signal process-kill SIGSTOP process-stop SIGCONT process-continue ((%equiv? . %equiv?)) %equiv? %equal-try ((time? . time?) (time->seconds . time->seconds) (seconds->time . seconds->time) (make-date . make-date) (date? . date?) (seconds->date . seconds->date) (date-nanosecond . date-nanosecond) (date-second . date-second) (date-minute . date-minute) (date-hour . date-hour) (date-day . date-day) (date-month . date-month) (date-year . date-year) (date-week-day . date-week-day) (date-year-day . date-year-day) (date-dst . date-dst) (date-tz . date-tz) (time-zone-name . time-zone-name) (seconds->list . seconds->list) (current-date . current-date) (current-time . current-time) (seconds->string . seconds->string) (date->string . date->string) (time-nanosecond . time-nanosecond) (set-time-nanosecond! . set-time-nanosecond!) (time-second . time-second) (set-time-second! . set-time-second!) (time-type . time-type) (set-time-type! . set-time-type!) (make-time . make-time) (time-tai->time-utc . time-tai->time-utc) (time-tai->time-utc! . time-tai->time-utc!) (time-utc->time-tai . time-utc->time-tai) (time-utc->time-tai! . time-utc->time-tai!) (%leap-second-table . %leap-second-table) (%leap-second-delta . %leap-second-delta) (%time-tai->time-utc! . %time-tai->time-utc!) (%time-utc->time-tai! . %time-utc->time-tai!)) \"since first argument is symbol, 3 args (type, nanosecond and second) required, only 2 given\" (time-tai time-utc time-monotonic time-process time-duration) \"bad time type ~S\" \"bad integer ~S\" \"bad integer ~S\" %time \"since first argument is integer, 2 args (nanosecond and second) required, but 3 given\" \"bad integer ~S\" time-utc \"bad symbol or integer ~S\" make-time type time-type set-time-type! second time-second set-time-second! nanosecond time-nanosecond set-time-nanosecond! struct-type time? 1000000000 %nano 86400 %sid exact->inexact time-seconds \"bad time ~S\" time->seconds inexact->exact #:time-utc seconds->time \"cannot convert ~S to a time\" \"bad number ~S\" ((1483228800 . 37) (1435708800 . 36) (1341100800 . 35) (1230768000 . 34) (1136073600 . 33) (915148800 . 32) (867715200 . 31) (820454400 . 30) (773020800 . 29) (741484800 . 28) (709948800 . 27) (662688000 . 26) (631152000 . 25) (567993600 . 24) (489024000 . 23) (425865600 . 22) (394329600 . 21) (362793600 . 20) (315532800 . 19) (283996800 . 18) (252460800 . 17) (220924800 . 16) (189302400 . 15) (157766400 . 14) (126230400 . 13) (94694400 . 12) (78796800 . 11) (63072000 . 10)) %leap-second-table %leap-second-delta %leap-second-neg-delta time-tai \"bad TAI time ~S\" %time-tai->time-utc! time-tai->time-utc time-tai->time-utc! \"bad UTC time ~S\" %time-utc->time-tai! time-utc->time-tai time-utc->time-tai! current-second %get-time-of-day %current-time-tai %current-time-utc %current-time \"too many arguments (0 or 1 expected, ~S given)\" \"unsupported time type ~S\" current-time %make-date-key %make-date-opt make-date #:nanosecond #:second #:minute #:hour #:day #:month #:year #:zone-offset %make-date \"bad ~s ~s\" check 999999999 minute hour day month \"bad year ~s\" \"bad zone offset ~s\" %date max date->seconds seconds->date local-timezone-offset week-day date-week-day year-day date-year-day dst date-dst tz date? date-tz \"Z\" abs #\\- \"~a~2f:~2f\" #\\0 string-map time-zone-name %seconds->date \"#[date ~A-~A-~A ~A:~A:~A]\" year struct-type-change-writer! date-nanosecond date-second date-minute date-hour date-day date-month date-year struct->list seconds->list current-date seconds->string \"bad string ~S\" #\\% \"%%\" #\\~ %seconds->string \"~c\" date->string \"bad string ~S\" ((bit-and . bit-and) (bit-or . bit-or) (bit-xor . bit-xor) (bit-not . bit-not) (bit-shift . bit-shift)) bit-and bit-xor %bit-and %bit-or %bit-xor bit-not bit-shift none ((make-thread . make-thread) (thread-handler-error-show . thread-handler-error-show) (thread-sleep! . thread-sleep!) (thread-join! . thread-join!) (mutex-lock! . mutex-lock!) (mutex-unlock! . mutex-unlock!) (join-timeout-exception? . join-timeout-exception?) (abandoned-mutex-exception? . abandoned-mutex-exception?) (terminated-thread-exception? . terminated-thread-exception?) (&uncaught-exception . &uncaught-exception) (uncaught-exception? . uncaught-exception?) (uncaught-exception-reason . uncaught-exception-reason)) \"bad timeout ~S\" %thread-timeout->seconds \"thread\" current-thread thread-name %build-error-location bold red \"**** Error \" blue \"(in thread ~S):\\n\" \"~A: ~A\\n\" normal \" (this error may be signaled again later)\\n\" %thread-end-exception-set! thread-handler-error-show %make-thread make-thread thread-sleep! \"cannot used #f as timeout\" %thread-sleep! thread-join! \"cannot join on myself (deadlock will occur)\" %thread-join! &thread-join-timeout %thread-end-exception &uncaught-exception reason %thread-end-result %mutex-lock! thread? &thread-abandonned-mutex %mutex-unlock! join-timeout-exception? abandoned-mutex-exception? &thread-terminated terminated-thread-exception? &condition (reason) make-condition-type uncaught-exception? uncaught-exception-reason ((make-external-function . make-external-function) (make-callback . make-callback) (define-external . define-external)) make-external-function make-callback ((#:void 0) (#:char 1) (#:short 2) (#:ushort 3) (#:int 4) (#:uint 5) (#:long 6) (#:ulong 7) (#:lonlong 8) (#:ulonlong 9) (#:float 10) (#:double 11) (#:boolean 12) (#:pointer 13) (#:string 14) (#:int8 15) (#:int16 16) (#:int32 17) (#:int64 18) (#:obj 19)) define-external \"parameter of type :void are forbidden\" \"bad type name ~S\" \"bad parameter description: ~S\" \"bad parameter description: ~S\" %make-ext-func %make-callback (lambda (name parameters . args) (let* ((lib (key-get args #:library-name \"\")) (lib-name (if (and (equal? lib \"\") (equal? (running-os) 'cygwin-windows)) \"cygwin1.dll\" lib)) (entry-name (key-get args #:entry-name (symbol->string name))) (return-type (key-get args #:return-type #:void))) `(define ,name (make-external-function ,entry-name ',parameters ,return-type ,lib-name)))) #:library-name \"\" \"\" \"cygwin1.dll\" #:entry-name #:return-type #:void ((write-shared . write-shared) (write-simple . write-simple) (letrec* . letrec*) (let-values . let-values) (let*-values . let*-values) (delay . delay) (delay-force . delay-force) (lazy . lazy) (make-promise . make-promise) (eager . eager) (define-values . define-values) (define-record-type . define-record-type) (equal-simple? . equal-simple?) (exact-integer? . exact-integer?) (floor-quotient . floor-quotient) (floor/ . floor/) (truncate/ . truncate/) (truncate-quotient . truncate-quotient) (truncate-remainder . truncate-remainder) (floor-remainder . floor-remainder) (square . square) (exact-integer-sqrt . exact-integer-sqrt) (exact . exact) (inexact . inexact) (boolean=? . boolean=?) (make-list . make-list) (member-simple . member-simple) (assoc-simple . assoc-simple) (member . member) (assoc . assoc) (symbol=? . symbol=?) (string=? . string=?) (%string2=? . %string2=?) (string . string) (%string2 . %string2) (string<=? . string<=?) (%string2<=? . %string2<=?) (string>? . string>?) (%string2>? . %string2>?) (string>=? . string>=?) (%string2>=? . %string2>=?) (string-ci=? . string-ci=?) (%string-ci2=? . %string-ci2=?) (string-ci . string-ci) (%string-ci2 . %string-ci2) (string-ci<=? . string-ci<=?) (%string-ci2<=? . %string-ci2<=?) (string-ci>? . string-ci>?) (%string-ci2>? . %string-ci2>?) (string-ci>=? . string-ci>=?) (%string-ci2>=? . %string-ci2>=?) (string->list . string->list) (string-copy! . string-copy!) (string-fill! . string-fill!) (%string-fill2! . %string-fill2!) (vector->list . vector->list) (vector-copy! . vector-copy!) (vector->string . vector->string) (string->vector . string->vector) (make-bytevector . make-bytevector) (bytevector? . bytevector?) (bytevector . bytevector) (bytevector-length . bytevector-length) (bytevector-u8-ref . bytevector-u8-ref) (bytevector-u8-set! . bytevector-u8-set!) (bytevector-copy! . bytevector-copy!) (string-map . string-map) (vector-map . vector-map) (string-for-each . string-for-each) (vector-for-each . vector-for-each) (error-object? . error-object?) (error-object-message . error-object-message) (error-object-irritants . error-object-irritants) (read-error? . read-error?) (file-error? . file-error?) (call-with-port . call-with-port) (input-port-open? . input-port-open?) (output-port-open? . output-port-open?) (read-string . read-string) (read-u8 . read-u8) (peek-u8 . peek-u8) (read-bytevector! . read-bytevector!) (write-string . write-string) (write-u8 . write-u8) (write-bytevector . write-bytevector) (with-exception-handler . with-exception-handler) (raise-continuable . raise-continuable) (guard . guard) (current-jiffy . current-jiffy) (jiffies-per-second . jiffies-per-second) (features . features) (%continuable-exception? . %continuable-exception?) (%continuable-exception-value . %continuable-exception-value)) write-shared write-simple letrec* (lambda (bindings . body) (if (list? bindings) (for-each (lambda (x) (unless (and (list? x) (= (length x) 2)) (error 'letrec* \"incorrect binding ~S\" x))) bindings) (error 'letrec* \"incorrect bindings ~S\" bindings)) `(let ,(map (lambda (x) (list (car x) #f)) bindings) ,@(map (lambda (x) `(set! ,@x)) bindings) (let () ,@body))) \"incorrect binding ~S\" \"incorrect bindings ~S\" let-values (lambda (bindings . body) (let ((tmps '())) (define (expand-once bindings tmps) (let ((first (car bindings))) `(call-with-values (lambda () ,(cadr first)) (lambda ,(map* (lambda (x) (cadr (assoc x tmps))) (car first)) ,(if (= (length bindings) 1) `(let ,tmps ,@body) (expand-once (cdr bindings) tmps)))))) (define (parse-binding binding) (unless (and (list? binding) (= (length binding) 2) (or (pair? (car binding)) (symbol? (car binding)))) (error 'let-values \"incorrect binding ~S\" binding)) (for-each* (lambda (x) (if (assoc x tmps) (error 'let-values \"duplicate binding ~s\" x) (set! tmps (cons (list x (gensym)) tmps)))) (car binding))) (for-each parse-binding bindings) (if (null? tmps) `(let () ,@body) (expand-once bindings tmps)))) \"incorrect binding ~S\" \"duplicate binding ~s\" let*-values (lambda (bindings . body) (if (> (length bindings) 1) `(let-values (,(car bindings)) (let*-values ,(cdr bindings) ,@body)) `(let-values ,bindings ,@body))) delay (lambda (exp) `(delay-force (%make-promise (list ,exp)))) delay-force %make-promise (lambda (exp) `(%make-promise (lambda () ,exp))) lazy (lambda (expr) `(delay-force ,expr)) promise? make-promise eager define-values (lambda (formals expr) (define (flat lst) (cond ((null? lst) lst) ((pair? lst) (cons (car lst) (flat (cdr lst)))) (else (list lst)))) (if (null? formals) `(call-with-values (lambda () ,expr) void) (let* ((tmps (map* (lambda (x) (gensym)) formals)) (ff (flat formals)) (ft (flat tmps))) `(begin ,@(map (lambda (x) `(define ,x #void)) ff) (call-with-values (lambda () ,expr) (lambda ,tmps ,@(map (lambda (x y) `(set! ,x ,y)) ff ft))) (values (void) ',formals))))) define-record-type (lambda (name constructor predicate . fields) (let ((struct-type (gensym)) (tmp (gensym)) (val (gensym))) `(begin (define ,(car constructor) #f) (define ,predicate #f) ,@(map (lambda (x) (case (length x) ((2) `(define ,(cadr x) #f)) ((3) `(begin (define ,(cadr x) #f) (define ,(caddr x) #f))) (else (error 'define-record-type \"bad field specification ~S\" x)))) fields) (let ((make-struct-type (%%in-scheme 'make-struct-type)) (make-struct (%%in-scheme 'make-struct)) (struct? (%%in-scheme 'struct?)) (struct-is-a? (%%in-scheme 'struct-is-a?)) (struct-ref (%%in-scheme 'struct-ref)) (struct-set! (%%in-scheme 'struct-set!))) (let ((,struct-type (make-struct-type ',name #f ',(map car fields)))) (set! ,(car constructor) (lambda ,(cdr constructor) (let ((,tmp (make-struct ,struct-type))) ,@(map (lambda (x) `(struct-set! ,tmp ',x ,x)) (cdr constructor)) ,tmp))) (set! ,predicate (lambda (,tmp) (and (struct? ,tmp) (struct-is-a? ,tmp ,struct-type)))) ,@(map (lambda (x) (if (= (length x) 2) `(set! ,(cadr x) (lambda (,tmp) (struct-ref ,tmp ',(car x)))) `(begin (set! ,(cadr x) (lambda (,tmp) (struct-ref ,tmp ',(car x)))) (set! ,(caddr x) (lambda (,tmp ,val) (struct-set! ,tmp ',(car x) ,val)))))) fields) (values (void) ',name)))))) \"bad field specification ~S\" equal-simple? exact-integer? floor-quotient floor-remainder floor/ truncate/ truncate-quotient truncate-remainder modulo square integer-length \"non negative integer expected. It was: ~S\" sqrt exact-integer-sqrt inexact boolean=? make-list member-simple assoc-simple symbol=? %generalize-string-compare (lambda (func func2) `(begin (define ,func2 ,func) (set! ,func (lambda (first . l) ,(string->keyword (symbol->string func)) (letrec ((compare (lambda (first . l) (or (null? l) (and (,func2 first (car l)) (apply compare l)))))) (unless (string? first) (error \"bad string ~W\" first)) (apply compare first l)))))) first l compare \"bad string ~W\" %string2=? %string2 string<=? %string2<=? string>? %string2>? string>=? %string2>=? string-ci=? %string-ci2=? string-ci %string-ci2 string-ci<=? %string-ci2<=? string-ci>? %string-ci2>? string-ci>=? %string-ci2>=? string-copy! \"bad string ~S\" \"bad string ~S\" \"bad destination index ~S\" \"bad integer for start index ~S\" \"bad integer for end index ~S\" \"not enough room in destination string ~S\" string-fill! %string-fill2! \"end index ~S < start index ~S\" vector-copy! \"bad vector ~S\" \"bad vector ~S\" \"bad destination index ~S\" \"bad integer for start index ~S\" \"bad integer for end index ~S\" \"not enough room in destination vector ~S\" \"bad vector ~S\" vector->string char? \"element at index ~S of ~S must be a character\" \"bad string ~S\" string->vector make-bytevector %make-uvector %uvector? bytevector? bytevector %uvector bytevector-length %uvector-length bytevector-u8-ref %uvector-ref bytevector-u8-set! %uvector-set! bytevector-copy! \"bad bytevector ~S\" \"bad bytevector ~S\" \"bad destination index ~S\" \"bad integer for start index ~S\" \"bad integer for end index ~S\" \"not enough room in destination bytevector ~S\" \"bad string ~S\" \"bad character in ~S\" vector-map \"bad list of vectors ~S\" string-for-each \"bad string ~S\" vector-for-each \"bad list of vectors ~S\" \"bad error object: ~S\" error-object-message \"bad error object: ~S\" error-object-irritants &read-error read-error? file-error? call-with-port \"bad input port ~S\" port-closed? input-port-open? \"bad output port ~S\" output-port-open? read-string \"parameter must be a positive integer. It was: ~S\" textual-port? \"bad textual input port ~S\" read-char eof-object read-u8 binary-port? \"bad binary port ~S\" read-byte peek-u8 \"bad binary port ~S\" peek-byte read-bytevector! \"bad bytevector ~S\" %read-bytevector! write-string %write-string write-u8 \"bad binary port ~S\" write-byte write-bytevector \"bad bytevector ~S\" \"bad binary port ~S\" %continuable-exception (value) make-%continuable-exception %continuable-exception? %continuable-exception-value \"exception handler returned on non-continuable exception\" with-exception-handler current-exception-handler raise-continuable guard (lambda (clauses . body) (let* ((var (car clauses)) (last (last-pair clauses)) (ex (gensym)) (old-hdlr (gensym)) (reraised (gensym)) (res (gensym))) `(let ((,old-hdlr (current-exception-handler))) (with-handler (lambda (,ex) (let* ((,var (if (%continuable-exception? ,ex) (%continuable-exception-value ,ex) ,ex)) (,reraised #f) (,res (cond ,@(cdr clauses) ,@(if (and (pair? last) (pair? (car last)) (eq? (caar last) 'else)) '() `((else (set! ,reraised #t) (,old-hdlr ,ex))))))) (if ,reraised ,res (if (%continuable-exception? ,ex) (raise ,res) ,res)))) ,@body)))) current-jiffy jiffies-per-second *all-features* SRFI-0 ((build-path-from-shell-variable . build-path-from-shell-variable) (install-path . install-path) (load-path . load-path) (load-suffixes . load-suffixes) (load-verbose . load-verbose) (current-loading-file . current-loading-file) (try-load . try-load) (load . load) (find-path . find-path) (require . require) (provide . provide) (provided? . provided?) (require/provide . require/provide) (warning-when-not-provided . warning-when-not-provided) (require-library . require-library) (require-for-syntax . require-for-syntax) (include . include) (include-ci . include-ci) (include-file . include-file) (autoload . autoload) (%stklos-conf-dir . %stklos-conf-dir) (%stklos-conf-file . %stklos-conf-file) (%try-load-conditions . %try-load-conditions) (%do-include . %do-include) (%%require . %%require)) \";\" \":\" *path-separator* %shared-suffix \"ostk\" \"stk\" \"sld\" \"scm\" *load-verbose* *load-path* \"HOME\" \".stklos\" \"XDG_CONFIG_HOME\" \"STKLOS_CONFDIR\" \"~/.config\" \"stklos\" %stklos-conf-dir %stklos-conf-file build-path-from-shell-variable \"STKLOS_LOAD_PATH\" \".\" lib \"bad list of path names ~S\" \"bad path name ~S\" \"bad list of suffixes ~S\" \"bad path name ~S\" load-suffixes load-verbose current-loading-file #:dirs \"cannot find configuration description\" \"bad keyword ~S\" \"cannot find directory for key ~S\" \"%guess-pathname: trying ~S\\n\" file-is-readable? \".\" \"/\" %guess-pathname \"path must be a string (it was ~s)\" \".?.?/\" try-load %primitive-try-load %try-load-conditions \";; Loading file ~S.\\n\" \";; File ~S loaded.\\n\" %try-load load \"cannot load file ~S\" \"cannot load file\" %cannot-load %load require provide provided? warning-when-not-provided \"^srfi-([1-9][0-9]*)$\" \"srfi/~a\" %rewrite-require-spec \"STKLOS_BUILDING\" \"WARNING: ~S was not provided~%\" provided (lambda (what) (if (string? what) (let ((spec (%rewrite-require-spec what (load-path) (load-suffixes)))) (if (and spec (cdr spec)) `(begin (define-module STklos (import ,(cdr spec))) (provide ,what)) `(%%require ,what #f))) `(%%require ,what #f))) require-library (lambda (what) `(%%require ,what #t)) require-for-syntax (lambda (file) `(%%require4syntax ,file)) %%require4syntax %do-include (lambda (kind files) (let ((inc (string->symbol (format \"%%~a\" kind)))) (if (null? files) (error kind \"at least one parameter must be provided\") `(,inc ,@(map (lambda (x) (or (find-path x) x)) files))))) \"%%~a\" \"at least one parameter must be provided\" (lambda files `(%do-include include ,files)) (lambda files `(%do-include include-ci ,files)) include-file (lambda (file) `(%%include ,file)) autoload (lambda (file . symbols) (let ((args (gensym)) (old (gensym))) `(begin ,@(map (lambda (x) `(define ,x (lambda ,args (let ((,old ,x)) (require ,file) (if (eq? ,old ,x) (error 'autoload \"~S has not been defined in ~S\" ',x ,file) (apply ,x ,args)))))) symbols)))) \"~S has not been defined in ~S\" ((define-library . define-library) (library-name . library-name) (library-list . library-list) (%module-define-and-export . %module-define-and-export) (%make-copy-module . %make-copy-module)) %module-define-and-export (lambda lst `(begin ,@(map (lambda (x) `(%symbol-define ',x ,x)) lst) (export ,@lst))) %make-copy-module (lambda (old new) (%%import (compiler-current-module) (list old)) `(define-module ,new (import ,old) (export ,@(module-exports (find-module old))))) define-library (lambda (name . decls) (let* ((module-name (%normalize-library-name name)) (conds '()) (imports '()) (exports '()) (body '()) (lib (gensym)) (module-restore (symbol-value '%module-restore (find-module 'SCHEME)))) (define (parse-declarations decls) (for-each (lambda (d) (unless (pair? d) (error 'define-library \"bad library declaration clause ~s\" d)) (let ((key (car d)) (rest (cdr d))) (case key ((import) (set! imports (append imports rest))) ((export) (set! exports (append exports rest))) ((begin include include-ci) (set! body (append body (list d)))) ((include-library-declarations) (for-each (lambda (path) (parse-declarations (call-with-input-file (or (find-path path) path) port->sexp-list))) rest)) ((cond-expand) (set! conds (cons d conds))) (else (error 'define-library \"incorrect directive ~s\" d))))) decls)) (parse-declarations decls) `(begin (define-module ,module-name (begin ,@(reverse! conds)) (import ,@imports) (export ,@exports) (%module->library! ',module-name) ,@body)))) \"bad library declaration clause ~s\" (begin include include-ci) include-library-declarations cond-expand \"incorrect directive ~s\" %module->library! library-name \"module ~S is not a library\" \"bad module/library ~S\" library-list ((string-lower . string-lower) (string-upper . string-upper) (set-load-path! . set-load-path!) (set-load-suffixes! . set-load-suffixes!) (flush . flush) (rewind-file-port . rewind-file-port) (hash-table->list . hash-table->list) (hash-table-put! . hash-table-put!) (hash-table-get . hash-table-get) (hash-table-remove! . hash-table-remove!) (stklos-pragma . stklos-pragma) (remove-directory . remove-directory) (%build-path-from-shell-variable . %build-path-from-shell-variable) (copy-tree . copy-tree) (%set-std-port! . %set-std-port!) (make-box . make-box) (make-constant-box . make-constant-box) (box-set! . box-set!) (string-index . string-index) (argv . argv) (fxdiv . fxdiv) (fxrem . fxrem) (fxmod . fxmod) (fx< . fx<) (fx<= . fx<=) (fx> . fx>) (fx>= . fx>=) (fx= . fx=) (make-directory . make-directory) (make-directories . make-directories) (process-signal . process-signal) (compiler:generate-signature . compiler:generate-signature)) string-downcase string-lower string-upper \"*** Obsolete function set-load-path!. Use load-path instead.\\n\" set-load-path! \"*** Obsolete function set-load-suffixes!. Use load-suffixes instead.\\n\" set-load-suffixes! port-rewind rewind-file-port hash-table->list hash-table-put! hash-table-get hash-table-delete! hash-table-remove! \"Don't use anymore pragma, but compiler:warn-use-undef parameter\" stklos-pragma pragma define-reader-ctor delete-directory remove-directory %build-path-from-shell-variable copy-tree %set-std-port! \"bad port number\" box make-box constant-box make-constant-box set-box! box-set! string-index argv fxdiv fxremainder fxrem fxmodulo fxmod make-directory make-directories process-signal %file-informations STKLOS-OBJECT ((SCHEME)) ((find-class . find-class) (is-a? . is-a?) (ensure-metaclass . ensure-metaclass) (ensure-metaclass-with-supers . ensure-metaclass-with-supers) (ensure-class . ensure-class) (ensure-generic-function . ensure-generic-function) (ensure-method . ensure-method) (add-method! . add-method!) (object-eqv? . object-eqv?) (object-equal? . object-equal?) (write-object . write-object) (display-object . display-object) (slot-unbound . slot-unbound) (slot-missing . slot-missing) (slot-definition-name . slot-definition-name) (slot-definition-options . slot-definition-options) (slot-definition-allocation . slot-definition-allocation) (slot-definition-getter . slot-definition-getter) (slot-definition-setter . slot-definition-setter) (slot-definition-accessor . slot-definition-accessor) (slot-definition-init-form . slot-definition-init-form) (slot-definition-init-keyword . slot-definition-init-keyword) (slot-init-function . slot-init-function) (class-slot-definition . class-slot-definition) (compute-get-n-set . compute-get-n-set) (allocate-instance . allocate-instance) (initialize . initialize) (make-instance . make-instance) (make . make) (no-next-method . no-next-method) (no-applicable-method . no-applicable-method) (no-method . no-method) (change-class . change-class) (change-object-class . change-object-class) (shallow-clone . shallow-clone) (deep-clone . deep-clone) (apply-generic . apply-generic) (apply-method . apply-method) (apply-methods . apply-methods) (compute-applicable-methods . compute-applicable-methods) (method-more-specific? . method-more-specific?) (sort-applicable-methods . sort-applicable-methods) (method-procedure . method-procedure) (method-specializers . method-specializers) (method-generic-function . method-generic-function) (method-specializers-equal? . method-specializers-equal?) (class-subclasses . class-subclasses) (class-methods . class-methods) (class-name . class-name) (class-direct-superclasses . class-direct-superclasses) (class-direct-subclasses . class-direct-subclasses) (class-precedence-list . class-precedence-list) (class-direct-methods . class-direct-methods) (class-direct-slots . class-direct-slots) (class-slots . class-slots) (generic-function-name . generic-function-name) (generic-function-methods . generic-function-methods) (generic-function-documentation . generic-function-documentation) (slot-value . slot-value) (define-class . define-class) (define-generic . define-generic) (method . method) (define-method . define-method)) class-redefinition \"bad class ~S\" %error-bad-class \"bad generic function ~S\" %error-bad-generic \"bad method ~S\" %error-bad-method make-closure specializers formals slot-definition-getter slot-definition-setter slot-definition-accessor declare-slots generic #:name ??? %make #:generic-function #:specializers #:procedure basic-make \"cannot make ~S with ~S\" make class? name class-name direct-supers class-direct-superclasses direct-slots class-direct-slots direct-subclasses class-direct-subclasses direct-methods class-direct-methods cpl class-precedence-list slots class-slots slot-definition-name slot-definition-options #:instance #:allocation slot-definition-allocation #:getter #:accessor #:init-form slot-definition-init-form #:init-keyword slot-definition-init-keyword getters-n-setters slot-init-function class-slot-definition generic-function-name methods generic-function-methods documentation generic-function-documentation method? generic-function method-generic-function method-specializers procedure method-procedure class-of is-a? find-class \"bad class ~S\" compute-slots \"bad slot name ~S\" %compute-slots #:dsupers #:slots \"metaclass\" ensure-metaclass-with-supers ensure-metaclass define-class (lambda (name supers slots . options) `(define ,name (ensure-class ',name ',supers ',(declare-slots slots) ,(or (key-get options #:metaclass #f) `(ensure-metaclass ',supers)) ,@options))) ensure-class #:metaclass \"super class ~S is duplicated in class ~S\" \"slot ~S is duplicated in class ~S\" define-generic (lambda (gf #:optional (meta ') #:key (documentation #f)) `(define ,gf (ensure-generic-function ',gf ,meta ,documentation))) #:documentation ensure-generic-function #:default %method-specializers-equal? method-specializers-equal? add-method-in-classes! remove-method-in-classes! compute-new-list-of-methods add-method! next-method ensure-method (lambda (args . body) (ensure-method #f args body)) define-method (lambda (name args . body) (let ((gf (gensym \"gf\"))) `(let ((,gf (ensure-generic-function ',name))) (add-method! ,gf ,(ensure-method gf args body)) (values (void) ',name)))) \"gf\" object-eqv? ( ) object-equal? ( ) write-object ( ) \"#[instance ~A]\" address-of ( ) slot-bound? \"#[~A ~A]\" ( ) \"#[~A ~A ~A]\" ( ) \"#[~A ~A (~A)]\" display-object ( ) slot-unbound ( ) \"slot ~S is unbound in #p~A (an object of class ~S)\" slot-missing ( . ) \"no slot with name `~S' in #p~A (an object of class ~S)\" no-next-method ( ) \"no next method for ~S in call ~S\" no-applicable-method ( ) \"no applicable method for ~S\\nin call ~S\" no-method ( ) \"no method defined for ~S\" shallow-clone () %allocate-instance deep-clone () instance? remove-class-accessors update-direct-method update-direct-subclass () ( ) ( ) ( ) redefined %find-inherited-get-n-set %direct-slot? #:before-slot-ref #:after-slot-ref #:before-slot-set! #:after-slot-set! %fast-slot-ref %fast-slot-set! %make-active-getter-n-setter compute-get-n-set ( ) nfields #:class #:each-subclass #:virtual #:slot-ref #:slot-set! \"a :slot-ref and a :slot-set! must be supplied in ~S\" #:active ( ) \"allocation type \\\"~S\\\" is unknown\" compute-slot-accessors %slot-ref closure? %procedure-arity \"bad getter closure for slot `~S' in ~S: ~S\" \"bad setter closure for slot `~S' in ~S: ~S\" list* compute-getters-n-setters compute-cpl initialize ( ) %initialize-object ( ) ( ) ( ) allocate-instance ( ) make-instance ( . ) slot-exists-using-class? slot-bound-using-class? slot-ref-using-class slot-set-using-class! %modify-instance change-object-class change-class ( ) compute-applicable-methods ( ) find-method method-more-specific? ( ) %method-more-specific? sort-applicable-methods ( ) apply-method ( ) %set-next-method! apply-methods ( ) apply-generic ( ) ( ) class-subclasses class-methods slot-value ( ) (