10552 lines
383 KiB
HTML
10552 lines
383 KiB
HTML
|
<!DOCTYPE html>
|
||
|
|
<html lang="en"><!-- documentation for s7 --><head>
|
||
|
|
<meta http-equiv="Content-Type" content="text/html; charset=UTF-8">
|
||
|
|
|
||
|
|
<title>s7</title>
|
||
|
|
|
||
|
|
<style type="text/css">
|
||
|
|
EM.red {color:red; font-style:normal}
|
||
|
|
EM.normal {font-style:normal}
|
||
|
|
EM.redb {color:red; font-weight: bold; font-style: normal}
|
||
|
|
EM.error {color:chocolate; font-style:normal}
|
||
|
|
EM.emdef {font-weight: bold; font-style: normal}
|
||
|
|
EM.green {color:green; font-style:normal}
|
||
|
|
EM.gray {color:#505050; font-style:normal}
|
||
|
|
EM.big {font-size: 20px; font-style: normal;}
|
||
|
|
EM.bigger {font-size: 30px; font-style: normal;}
|
||
|
|
EM.def {font-style: normal}
|
||
|
|
|
||
|
|
H1 {text-align: center}
|
||
|
|
UL {list-style-type: none}
|
||
|
|
|
||
|
|
A {text-decoration:none}
|
||
|
|
A:hover {text-decoration:underline}
|
||
|
|
|
||
|
|
A.def {font-weight: bold;
|
||
|
|
font-style: normal;
|
||
|
|
text-decoration:none;
|
||
|
|
text-color:black;
|
||
|
|
}
|
||
|
|
|
||
|
|
PRE.indented {padding-left: 1.0cm;}
|
||
|
|
|
||
|
|
DIV.indented {background-color: #F8F8F0;
|
||
|
|
padding-left: 0.5cm;
|
||
|
|
padding-right: 0.5cm;
|
||
|
|
padding-top: 0.5cm;
|
||
|
|
padding-bottom: 0.5cm;
|
||
|
|
margin-bottom: 0.5cm;
|
||
|
|
border: 1px solid gray;
|
||
|
|
border-radius: 20px;
|
||
|
|
-moz-border-radius: 20px;
|
||
|
|
-webkit-border-radius: 20px;
|
||
|
|
}
|
||
|
|
DIV.small {font-size: small;
|
||
|
|
padding-left: 0.5cm;
|
||
|
|
padding-right: 0.5cm;
|
||
|
|
padding-bottom: 0.5cm;
|
||
|
|
}
|
||
|
|
DIV.header {margin-top: 60px;
|
||
|
|
margin-bottom: 30px;
|
||
|
|
border: 4px solid #00ff00; /* green */
|
||
|
|
background-color: #eefdee; /* lightgreen */
|
||
|
|
padding-left: 30px;
|
||
|
|
}
|
||
|
|
DIV.shortheader {margin-top: 30px;
|
||
|
|
margin-bottom: 10px;
|
||
|
|
border: 4px solid #00ff00; /* green */
|
||
|
|
background-color: #f5f5dc;
|
||
|
|
padding-left: 30px;
|
||
|
|
padding-top: 5px;
|
||
|
|
padding-bottom: 5px;
|
||
|
|
width: 20%;
|
||
|
|
}
|
||
|
|
DIV.topheader {margin-top: 10px;
|
||
|
|
margin-bottom: 40px;
|
||
|
|
border: 4px solid #00ff00; /* green */
|
||
|
|
background-color: #f5f5dc; /* beige */
|
||
|
|
font-family: 'Helvetica';
|
||
|
|
font-size: 30px;
|
||
|
|
text-align: center;
|
||
|
|
padding-top: 10px;
|
||
|
|
padding-bottom: 10px;
|
||
|
|
}
|
||
|
|
DIV.separator {margin-top: 30px;
|
||
|
|
margin-bottom: 10px;
|
||
|
|
border: 2px solid #00ff00; /* green */
|
||
|
|
background-color: #f5f5dc; /* beige */
|
||
|
|
padding-top: 4px;
|
||
|
|
width: 30%;
|
||
|
|
border-radius: 4px;
|
||
|
|
-moz-border-radius: 4px;
|
||
|
|
-webkit-border-radius: 4px;
|
||
|
|
}
|
||
|
|
BODY.body {background-color: #ffffff; /* white */
|
||
|
|
margin-right: 20px;
|
||
|
|
margin-left: 20px;
|
||
|
|
}
|
||
|
|
DIV.listener {background-color: #f0f8ff;
|
||
|
|
font-family: 'Monospace';
|
||
|
|
padding-left: 6px;
|
||
|
|
padding-right: 6px;
|
||
|
|
padding-bottom: 4px;
|
||
|
|
margin-left: 1.0cm;
|
||
|
|
margin-right: 4.0cm;
|
||
|
|
border: 2px solid #a0a0a0;
|
||
|
|
}
|
||
|
|
LI.li_header {padding-top: 20px;}
|
||
|
|
|
||
|
|
</style>
|
||
|
|
</head>
|
||
|
|
<body class="body">
|
||
|
|
|
||
|
|
<!-- INDEX s7doc:s7 scheme -->
|
||
|
|
|
||
|
|
|
||
|
|
<div class="topheader" id="s7doc">s7
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<p>s7 is a Scheme implementation intended as an extension language
|
||
|
|
for other applications, primarily Snd, Radium, Common Music, and Max/MSP through the Scheme For Max external.
|
||
|
|
It exists as just two files, s7.c and
|
||
|
|
s7.h, that want only to disappear into someone else's source tree. There are no libraries,
|
||
|
|
no run-time init files, and no configuration scripts.
|
||
|
|
It can be built as a stand-alone
|
||
|
|
interpreter (see <a href="#repl">below</a>). s7test.scm is a regression test for s7.
|
||
|
|
A tarball is available: <a href="https://ccrma.stanford.edu/software/s7/s7.tar.gz">s7 tarball</a>.
|
||
|
|
There is an svn repository at sourceforge (the Snd project): <a href="https://sourceforge.net/p/snd/svn1/">Snd</a>,
|
||
|
|
and a git repository (just s7): git@cm-gitlab.stanford.edu:bil/s7.git <a href="https://cm-gitlab.stanford.edu/bil/s7.git">s7.git</a>.
|
||
|
|
Please ignore all other "s7" github sites. Christos Vagias created a web-assembly site with
|
||
|
|
a repl: https://github.com/actonDev/s7-playground/.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
s7 is the default extension language of Snd and sndlib (<a href="http://ccrma.stanford.edu/software/snd/index.html">snd</a>),
|
||
|
|
Rick Taube's Common Music (commonmusic at sourceforge), and Kjetil Matheussen's Radium music editor.
|
||
|
|
There are X, Motif, and openGL bindings
|
||
|
|
in libxm in the Snd tarball, or at ftp://ccrma-ftp.stanford.edu/pub/Lisp/libxm.tar.gz.
|
||
|
|
If you're running s7 in a context
|
||
|
|
that has getenv, file-exists?, and system, you can use s7-slib-init.scm
|
||
|
|
to gain easy access to slib. This init file is named "s7.init" in the slib distribution.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Although it is a descendant of tinyScheme, s7 is closest as a Scheme dialect to Guile 1.8.
|
||
|
|
I believe it is compatible with <a href="#s7vsr5rs">r5rs</a> and <a href="#r7rs">r7rs</a>: you can just ignore all the additions discussed in this file.
|
||
|
|
It has continuations,
|
||
|
|
ratios, complex numbers,
|
||
|
|
macros, keywords, hash-tables,
|
||
|
|
multiprecision arithmetic,
|
||
|
|
generalized set!, unicode, and so on.
|
||
|
|
It does not have syntax-rules or any of
|
||
|
|
its friends, and it does not think there is any such thing
|
||
|
|
as an inexact integer.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>This file assumes you know about Scheme and all its problems,
|
||
|
|
and want a quick tour of where s7 is different. (Well, it was quick once upon a time).
|
||
|
|
The main difference: if it's in s7, it's a first-class citizen of s7, and that includes
|
||
|
|
macros, environments, and syntactic values.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<br>
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<p>I originally used a small font for scholia, but now I have to squint
|
||
|
|
to read that tiny text, so less-than-vital commentaries are shown in the normal font, but
|
||
|
|
indented and on a sort of brownish background.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
<br>
|
||
|
|
|
||
|
|
<ul>
|
||
|
|
<li><a href="#multiprecision">arbitrary precision arithmetic</a>
|
||
|
|
</li><li><a href="#math">math functions</a>
|
||
|
|
</li><li><a href="#define*">define*, named let*</a>
|
||
|
|
</li><li><a href="#macros">define-macro</a>
|
||
|
|
</li><li><a href="#pws">setter</a>
|
||
|
|
</li><li><a href="#generalizedset">generic functions, generalized set!</a>
|
||
|
|
</li><li><a href="#multidimensionalvectors">multidimensional vectors</a>
|
||
|
|
</li><li><a href="#hashtables">hash tables</a>
|
||
|
|
</li><li><a href="#environments">environments</a>
|
||
|
|
</li><li><a href="#multiplevalues">multiple-values</a>
|
||
|
|
</li><li><a href="#callwithexit1">call-with-exit</a>
|
||
|
|
</li><li><a href="#format1">format</a>
|
||
|
|
</li><li><a href="#hooks">hooks</a>
|
||
|
|
</li><li><a href="#variableinfo">variable info</a>
|
||
|
|
</li><li><a href="#evalstring">eval</a>
|
||
|
|
</li><li><a href="#IO">IO and other OS functions</a>
|
||
|
|
</li><li><a href="#errors">errors</a>
|
||
|
|
</li><li><a href="#autoload">autoload</a>
|
||
|
|
</li><li><a href="#constants">define-constant</a>
|
||
|
|
</li><li><a href="#miscellanea">marvels and curiousities:</a>
|
||
|
|
|
||
|
|
<ul>
|
||
|
|
<li><a href="#loadpath">*load-path*</a>, <a href="#featureslist">*features*</a>, <a href="#sharpreaders">*#readers*</a>,
|
||
|
|
</li><li><a href="#makelist">make-list</a>, <a href="#charposition">char-position</a>, <a href="#keywords">keywords</a>
|
||
|
|
</li><li><a href="#symboltable">symbol-table</a>, <a href="#s7help">help</a>, <a href="#s7gc">gc</a>, <a href="#equivalentp">equivalent?</a>
|
||
|
|
</li><li><a href="#expansion">define-expansion</a>, <a href="#s7env">*s7*</a>, <a href="#s7vsr5rs">r5rs</a>, <a href="#r7rs">r7rs</a>,
|
||
|
|
</li><li><a href="#profiling">profiling</a>, <a href="#legolambda">legolambda</a>, etc...
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
</li><li class="li_header"><a href="#FFIexamples">FFI examples</a>
|
||
|
|
<ul>
|
||
|
|
<li><a href="#repl">read-eval-print loop (and emacs)</a>
|
||
|
|
</li><li><a href="#defun">define a function with arguments and a returned value, and define a variable </a>
|
||
|
|
</li><li><a href="#defvar">call a Scheme function from C, and get/set Scheme variable values in C</a>
|
||
|
|
</li><li><a href="#juce">C++ and Juce</a>
|
||
|
|
</li><li><a href="#sndlib">load sndlib using the Xen functions and macros</a>
|
||
|
|
</li><li><a href="#pwstype">add a new Scheme type and a procedure with a setter</a>
|
||
|
|
</li><li><a href="#functionportexample">redirect display output to a C procedure</a>
|
||
|
|
</li><li><a href="#extendop">extend a built-in operator ("+" in this case)</a>
|
||
|
|
</li><li><a href="#definestar1">C-side define* (s7_define_function_star)</a>
|
||
|
|
</li><li><a href="#definemacro1">C-side define-macro (s7_define_macro)</a>
|
||
|
|
</li><li><a href="#definegeneric">define a generic function in C</a>
|
||
|
|
</li><li><a href="#signal">signal handling (C-C to break out of an infinite loop)</a>
|
||
|
|
</li><li><a href="#notify">notification in C that a Scheme variable has been set!</a>
|
||
|
|
</li><li><a href="#namespace">Load C defined stuff into a separate namespace</a>
|
||
|
|
</li><li><a href="#Cerrors">Error handling in C</a>
|
||
|
|
</li><li><a href="#testhook">Hooks in C and Scheme</a>
|
||
|
|
</li><li><a href="#dload">Load a C module dynamically</a>
|
||
|
|
</li><li><a href="#gmpex">gmp and friends</a>
|
||
|
|
</li><li><a href="#gdb">gdb</a>
|
||
|
|
</li><li><a href="#ffinotes">FFI notes</a>
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
</li><li class="li_header"><a href="#s7examples">s7 examples</a>
|
||
|
|
<ul>
|
||
|
|
<li><a href="#cload">cload.scm</a>
|
||
|
|
<ul>
|
||
|
|
<li><a href="#libc">libc</a>
|
||
|
|
</li><li><a href="#libgsl">libgsl</a>
|
||
|
|
</li><li><a href="#libgdbm">libgdbm</a>
|
||
|
|
</li></ul>
|
||
|
|
</li><li><a href="#case">case.scm</a>
|
||
|
|
</li><li><a href="#debug">debug.scm</a>
|
||
|
|
</li><li><a href="#lint">lint.scm</a>
|
||
|
|
</li><li><a href="#schemerepl">repl.scm and nrepl.scm</a>
|
||
|
|
</li></ul>
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="multiprecision"><h4>multiprecision arithmetic</h4></div>
|
||
|
|
|
||
|
|
<p>All numeric types, integers, ratios, reals, and complex numbers are supported.
|
||
|
|
The basic integer and real
|
||
|
|
types are defined in s7.h, defaulting to int64_t and double.
|
||
|
|
A ratio consists of two integers, a complex number two reals.
|
||
|
|
pi is predefined.
|
||
|
|
s7 can be built with multiprecision support
|
||
|
|
for all types, using the gmp, mpfr, and mpc libraries (set WITH_GMP to 1 in s7.c).
|
||
|
|
If multiprecision arithmetic is
|
||
|
|
enabled, the following functions are included: bignum, and bignum?, and the variable (*s7* 'bignum-precision).
|
||
|
|
(*s7* 'bignum-precision) defaults to 128; it sets the number of bits each float takes.
|
||
|
|
pi automatically reflects the current (*s7* 'bignum-precision):
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> pi
|
||
|
|
<em class="gray">3.141592653589793238462643383279502884195E0</em>
|
||
|
|
> (*s7* 'bignum-precision)
|
||
|
|
<em class="gray">128</em>
|
||
|
|
> (set! (*s7* 'bignum-precision) 256)
|
||
|
|
<em class="gray">256</em>
|
||
|
|
> pi
|
||
|
|
<em class="gray">3.141592653589793238462643383279502884197169399375105820974944592307816406286198E0</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<em class="def" id="bignump">bignum?</em> returns #t if its argument is a big number of some type; I use "bignum"
|
||
|
|
for any big number, not just integers. To create a big number,
|
||
|
|
either include enough digits to overflow the default types, or use the <em class="def" id="bignum">bignum</em> function.
|
||
|
|
Its argument is either a number which it casts to a bignum, or a string representing the desired number:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (bignum "123456789123456789")
|
||
|
|
<em class="gray">123456789123456789</em>
|
||
|
|
> (bignum "1.123123123123123123123123123")
|
||
|
|
<em class="gray">1.12312312312312312312312312300000000009E0</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>For read-time bignums:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(set! *#readers*
|
||
|
|
(cons (cons #\B (lambda (str)
|
||
|
|
(bignum (string->number (substring str 1)))))
|
||
|
|
*#readers*))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>and now #B123 is the reader equivalent of (bignum 123).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>In the non-gmp case, if s7 is built using doubles (s7_double in s7.h), the float "epsilon" is
|
||
|
|
around (expt 2 -53), or about 1e-16. In the gmp case, it is around (expt 2 (- (*s7* 'bignum-precision))).
|
||
|
|
So in the default case (precision = 128), using gmp:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (= 1.0 (+ 1.0 (expt 2.0 -128)))
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
> (= 1.0 (+ 1.0 (expt 2.0 -127)))
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>and in the non-gmp case:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (= 1.0 (+ 1.0 (expt 2 -53)))
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
> (= 1.0 (+ 1.0 (expt 2 -52)))
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>In the gmp case, integers and ratios are limited only by the size of memory,
|
||
|
|
but reals are limited by (*s7* 'bignum-precision). This means, for example, that
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (floor 1e56) ; (*s7* 'bignum-precision) is 128
|
||
|
|
<em class="gray">99999999999999999999999999999999999999927942405962072064</em>
|
||
|
|
> (set! (*s7* 'bignum-precision) 256)
|
||
|
|
<em class="gray">256</em>
|
||
|
|
> (floor 1e56)
|
||
|
|
<em class="gray">100000000000000000000000000000000000000000000000000000000</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The non-gmp case is similar, but it's easy to find the edge cases:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (floor (+ 0.9999999995 (expt 2.0 23)))
|
||
|
|
<em class="gray">8388609</em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="math"><h4>math functions</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<p>
|
||
|
|
s7 includes:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<ul>
|
||
|
|
<li>sinh, cosh, tanh, asinh, acosh, atanh
|
||
|
|
</li><li>logior, logxor, logand, lognot, logbit?, ash, integer-decode-float
|
||
|
|
</li><li>random
|
||
|
|
</li><li>nan?, infinite?
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
The random function can take any numeric argument, including 0.
|
||
|
|
Other math-related differences between s7 and r5rs:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<ul style="list-style-type:disc;">
|
||
|
|
<li>rational? and exact mean integer or ratio (i.e. not floating point), inexact means not exact.
|
||
|
|
</li><li>floor, ceiling, truncate, and round return (exact) integer results.
|
||
|
|
</li><li>"#" does not stand for an unknown digit.
|
||
|
|
</li><li>the "@" complex number notation is not supported ("@" is an exponent marker in s7).
|
||
|
|
</li><li>"+i" is not considered a number; include the real part.
|
||
|
|
</li><li>modulo, remainder, and quotient take integer, ratio, or real arguments.
|
||
|
|
</li><li>lcm and gcd can take integer or ratio arguments.
|
||
|
|
</li><li>log takes an optional second argument, the base.
|
||
|
|
</li><li>'.' and an exponent can occur in a number in any base.
|
||
|
|
</li><li>rationalize returns a ratio!
|
||
|
|
</li><li>case is significant in numbers, as elsewhere: #b0 is 0, but #B0 is an error.
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
<pre class="indented">> (exact? 1.0)
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
> (rational? 1.5)
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
> (floor 1.4)
|
||
|
|
<em class="gray">1</em>
|
||
|
|
> (remainder 2.4 1)
|
||
|
|
<em class="gray">0.4</em>
|
||
|
|
> (modulo 1.4 1.0)
|
||
|
|
<em class="gray">0.4</em>
|
||
|
|
> (lcm 3/4 1/6)
|
||
|
|
<em class="gray">3/2</em>
|
||
|
|
> (log 8 2)
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (number->string 0.5 2)
|
||
|
|
<em class="gray">"0.1"</em>
|
||
|
|
> (string->number "0.1" 2)
|
||
|
|
<em class="gray">0.5</em>
|
||
|
|
> (rationalize 1.5)
|
||
|
|
<em class="gray">3/2</em>
|
||
|
|
> (complex 1/2 0)
|
||
|
|
<em class="gray">1/2</em>
|
||
|
|
> (logbit? 6 1) ; argument order, (logbit? int index), follows gmp, not CL
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>See <a href="#libgsl">cload and libgsl.scm</a> for easy access to GSL,
|
||
|
|
and similarly libm.scm for the C math library.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>The exponent itself is always in base 10; this follows gmp usage.
|
||
|
|
Scheme normally uses "@" for its useless polar notation, but that
|
||
|
|
means <code>(string->number "1e1" 16)</code> is ambiguous — is the "e" a digit or an exponent marker?
|
||
|
|
In s7, "@" is an exponent marker.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (string->number "1e9" 2) ; (expt 2 9)
|
||
|
|
<em class="gray">512.0</em>
|
||
|
|
> (string->number "1e1" 12) ; "e" is not a digit in base 12
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
> (string->number "1e1" 16) ; (+ (* 1 16 16) (* 14 16) 1)
|
||
|
|
<em class="gray">481</em>
|
||
|
|
> (string->number "1.2e1" 3); (* 3 (+ 1 2/3))
|
||
|
|
<em class="gray">5.0</em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>
|
||
|
|
What is <code>(/ 1.0 0.0)</code>? s7 gives a "division by zero" error here, and also in <code>(/ 1 0)</code>.
|
||
|
|
Guile returns +inf.0 in the first case, which seems reasonable, but a "numerical overflow" error in the second.
|
||
|
|
Slightly weirder is <code>(expt 0.0 0+i)</code>. Currently s7 returns 0.0, Guile returns +nan.0+nan.0i,
|
||
|
|
Clisp and sbcl throw an error. Everybody agrees that <code>(expt 0 0)</code> is 1, and Guile thinks
|
||
|
|
that <code>(expt 0.0 0.0)</code> is 1.0. But <code>(expt 0 0.0)</code> and <code>(expt 0.0 0)</code> return different
|
||
|
|
results in Guile (1 and 1.0), both are 0.0 in s7, the first is an error in Clisp, but the second returns 1,
|
||
|
|
and so on — what a mess! This mess was made a lot worse than it needs to be when the IEEE decreed that
|
||
|
|
0.0 equals -0.0, so we can't tell them apart, but that they produce different results in nearly every use!
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">scheme@(guile-user)> (= -0.0 0.0)
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
scheme@(guile-user)> (negative? -0.0)
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
scheme@(guile-user)> (= (/ 1.0 0.0) (/ 1.0 -0.0))
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
scheme@(guile-user)> (< (/ 1.0 -0.0) -1e100 1e100 (/ 1.0 0.0))
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
How can they be equal? In s7, the sign
|
||
|
|
of -0.0 is ignored, and they really are equal.
|
||
|
|
One other oddity: two floats can satisfy eq? and yet not be eqv?:
|
||
|
|
<code>(eq? +nan.0 +nan.0)</code> might be #t (it is unspecified), but <code>(eqv? +nan.0 +nan.0)</code> is #f.
|
||
|
|
The same problem afflicts memq and assq.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>The <em class="def" id="random">random</em> function takes a range and an optional state, and returns a number
|
||
|
|
between zero and the range, of the same type as the range. It is perfectly reasonable
|
||
|
|
to use a range of 0, in which case random returns 0.
|
||
|
|
<em class="def" id="randomstate">random-state</em> creates a new random state from a seed. If no state is passed,
|
||
|
|
random uses some default state initialized from the current time. <em class="def" id="randomstatep">random-state?</em> returns #t if passed a random state object.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (random 0)
|
||
|
|
<em class="gray">0</em>
|
||
|
|
> (random 1.0)
|
||
|
|
<em class="gray">0.86331198514245</em>
|
||
|
|
> (random 3/4)
|
||
|
|
<em class="gray">654/1129</em>
|
||
|
|
> (random 1+i)
|
||
|
|
<em class="gray">0.86300308872748+0.83601002730848i</em>
|
||
|
|
> (random -1.0)
|
||
|
|
<em class="gray">-0.037691127513267</em>
|
||
|
|
> (define r0 (random-state 1234))
|
||
|
|
<em class="gray">r0</em>
|
||
|
|
> (random 100 r0)
|
||
|
|
<em class="gray">94</em>
|
||
|
|
> (random 100 r0)
|
||
|
|
<em class="gray">19</em>
|
||
|
|
> (define r1 (random-state 1234))
|
||
|
|
<em class="gray">r1</em>
|
||
|
|
> (random 100 r1)
|
||
|
|
<em class="gray">94</em>
|
||
|
|
> (random 100 r1)
|
||
|
|
<em class="gray">19</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>copy the random-state to save a spot in a random number sequence, or save the random-state as a list via
|
||
|
|
random-state->list, then to restart from that point, apply random-state to that list.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>I can't find the right tone for this section; this is the 400-th revision; I wish I were a better writer!
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>In some Schemes,
|
||
|
|
"rational" means "could possibly be
|
||
|
|
expressed equally well as a ratio: floats are approximations". In s7
|
||
|
|
it's: "is actually expressed (at the scheme level) as a ratio (or an
|
||
|
|
integer of course)";
|
||
|
|
otherwise "rational?" is the same as "real?":
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(not-s7)> (rational? (sqrt 2))
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>That 1.0 is represented at the IEEE-float level as a sort of
|
||
|
|
ratio does not mean it has to be a scheme ratio; the two notions are independent.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>But that confusion is trivial compared to the completely nutty "inexact integer".
|
||
|
|
As I understand it, "inexact" originally meant "floating point", and "exact" meant integer or ratio of integers.
|
||
|
|
But words have a life of their own.
|
||
|
|
0.0 somehow became an "inexact" integer (although it can be represented exactly in floating
|
||
|
|
point).
|
||
|
|
+inf.0 must be an integer —
|
||
|
|
its fractional part is explicitly zero! But +nan.0...
|
||
|
|
And then there's:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(not-s7)> (integer? 9007199254740993.1)
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
When does this matter? I often need to index into a vector, but the index is a float (a "real" in Scheme-speak: its
|
||
|
|
fractional part can be non-zero).
|
||
|
|
In one Scheme:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(not-s7)> (vector-ref #(0) (floor 0.1))
|
||
|
|
<em class="gray">ERROR: Wrong type (expecting exact integer): 0.0 </em>; [why? "it's probably a programmer mistake"!]
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Not to worry, I'll use inexact->exact:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(not-s7)> (inexact->exact 0.1)
|
||
|
|
<em class="gray">3602879701896397/36028797018963968 </em>; [why? "floats are ratios"!]
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>So I end up using the verbose <code>(floor (inexact->exact ...))</code> everywhere, and even
|
||
|
|
then I have no guarantee that I'll get a legal vector index.
|
||
|
|
I have never seen any use made of the exact/inexact distinction — just
|
||
|
|
wild flailing to try get around it.
|
||
|
|
I think the whole idea is confused and useless, and leads
|
||
|
|
to verbose and buggy code.
|
||
|
|
If we discard it,
|
||
|
|
we can maintain backwards compatibility via:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define exact? rational?)
|
||
|
|
(define (inexact? x) (not (rational? x)))
|
||
|
|
(define inexact->exact rationalize) ; or floor
|
||
|
|
(define (exact->inexact x) (* x 1.0))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Standard Scheme's #i and #e are also useless because you can
|
||
|
|
have any number after, for example, #b:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> #b1.1
|
||
|
|
<em class="gray">1.5</em>
|
||
|
|
> #b1e2
|
||
|
|
<em class="gray">4.0</em>
|
||
|
|
> #o17.5+i
|
||
|
|
<em class="gray">15.625+1i</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>(But s7 uses #i for int-vector and does not implement #e).
|
||
|
|
Speaking of #b and friends, what should <code>(string->number "#xffff" 2)</code> return?
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="define*"><h4>define*, lambda*</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<p><em class="def" id="definestar">define*</em> and
|
||
|
|
<em class="def" id="lambdastar">lambda*</em>
|
||
|
|
are extensions of define and lambda that make it easier
|
||
|
|
to deal with optional, keyword, and rest arguments.
|
||
|
|
The syntax is very simple: every argument to define* has a default value
|
||
|
|
and is automatically available as a keyword argument. The default value
|
||
|
|
is either #f if unspecified, or given in a list whose first member is
|
||
|
|
the argument name.
|
||
|
|
The last argument
|
||
|
|
can be preceded by :rest or a dot to indicate that all other trailing arguments
|
||
|
|
should be packaged as a list under that argument's name. A trailing or rest
|
||
|
|
argument's default value is () and can't be specified in the declaration.
|
||
|
|
The rest argument is not available as a keyword argument.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(<em class="red">define*</em> (hi a (b 32) (c "hi")) (list a b c))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Here the argument "a" defaults to #f, "b" to 32, etc.
|
||
|
|
When the function is called,
|
||
|
|
the argument names are set from the values passed the function,
|
||
|
|
then any unset arguments are bound to their default values, evaluated in left-to-right order.
|
||
|
|
As the current argument list is scanned, any name that occurs as a keyword, :arg for example where the parameter name is arg,
|
||
|
|
sets that argument's new value. Otherwise, as values occur, they
|
||
|
|
are plugged into the actual argument list based on their position, counting a keyword/value pair as one argument.
|
||
|
|
This is called an optional-key list in CLM. So, taking the function
|
||
|
|
above as an example:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (hi 1)
|
||
|
|
<em class="gray">(1 32 "hi")</em>
|
||
|
|
> (hi :b 2 :a 3)
|
||
|
|
<em class="gray">(3 2 "hi")</em>
|
||
|
|
> (hi 3 2 1)
|
||
|
|
<em class="gray">(3 2 1)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>See s7test.scm for many examples. (s7's define* is very close to srfi-89's define*).
|
||
|
|
To mark an argument as required, set its default value to a call on the error function:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (define* (f a (b (error 'unset-arg "f's b parameter not set"))) (list a b))
|
||
|
|
<em class="gray">f</em>
|
||
|
|
> (f 1 2)
|
||
|
|
(1 2)
|
||
|
|
> (f 1)
|
||
|
|
<em class="red">error</em><em class="gray">: f's b parameter not set</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>The combination of optional and keyword arguments is viewed with
|
||
|
|
disfavor in the Lisp
|
||
|
|
community, but the problem is in CL's implementation of the idea, not
|
||
|
|
the idea itself.
|
||
|
|
I've used the s7 style since around 1976, and have never found it
|
||
|
|
confusing. The mistake
|
||
|
|
in CL is to require the optional arguments if a keyword argument occurs,
|
||
|
|
and to consider them as distinct from the
|
||
|
|
keyword arguments. So everyone forgets and puts a keyword where CL
|
||
|
|
expects a required-optional
|
||
|
|
argument. CL then does something ridiculous, and the programmer stomps
|
||
|
|
around shouting about keywords, but the fault lies with CL.
|
||
|
|
If s7's way is considered too loose, one way to tighten it might be to
|
||
|
|
insist that once a keyword
|
||
|
|
is used, only keyword argument pairs can follow.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>A natural companion of lambda* is named let*. In named let, the implicit function's
|
||
|
|
arguments have initial values, but thereafter, each call requires the full set of arguments.
|
||
|
|
Why not treat the initial values as default values?
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let* func ((i 1) (j 2))
|
||
|
|
(+ i j (if (> i 0) (func (- i 1)) 0)))
|
||
|
|
<em class="gray">5</em>
|
||
|
|
> (letrec ((func (lambda* ((i 1) (j 2))
|
||
|
|
(+ i j (if (> i 0) (func (- i 1)) 0)))))
|
||
|
|
(func))
|
||
|
|
<em class="gray">5</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>This is consistent with the lambda* arguments because their defaults are
|
||
|
|
already set in left-to-right order, and as each parameter is set to its default value,
|
||
|
|
the binding is added to the default value expression environment (just as if it were a let*).
|
||
|
|
The let* name itself (the implicit function) is not defined until after the bindings
|
||
|
|
have been evaluated (as in named let).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>In CL, keyword default values are handled in the same way:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (defun foo (&key (a 0) (b (+ a 4)) (c (+ a 7))) (list a b c))
|
||
|
|
<em class="gray">FOO </em>
|
||
|
|
> (foo :b 2 :a 60)
|
||
|
|
<em class="gray">(60 2 67) </em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>In s7, we'd use:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define* (foo (a 0) (b (+ a 4)) (c (+ a 7))) (list a b c))
|
||
|
|
</pre>
|
||
|
|
<p>Also CL and s7 handle keywords as values in the same way:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (defun foo (&key a) a)
|
||
|
|
<em class="gray">FOO</em>
|
||
|
|
> (defvar x :a)
|
||
|
|
<em class="gray">X</em>
|
||
|
|
> (foo x 1)
|
||
|
|
<em class="gray">1</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<pre class="indented">> (define* (foo a) a)
|
||
|
|
<em class="gray">foo</em>
|
||
|
|
> (define x :a)
|
||
|
|
<em class="gray">:a</em>
|
||
|
|
> (foo x 1)
|
||
|
|
<em class="gray">1</em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>To try to catch what I believe are usually mistakes, I added two
|
||
|
|
error checks. One is triggered if you set the same parameter twice
|
||
|
|
in the same call, and the other if an unknown keyword is encountered
|
||
|
|
in the key position. To turn off these errors, add :allow-other-keys
|
||
|
|
at the end of the parameter list.
|
||
|
|
These problems arise in a case such as
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define* (f (a 1) (b 2)) (list a b))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>You could do any of the following by accident:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(f 1 :a 2) ; what is a?
|
||
|
|
(f :b 1 2) ; what is b?
|
||
|
|
(f :c 3) ; did you really want a to be :c and b to be 3?
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>In the last case, to pass a keyword deliberately, either include the
|
||
|
|
argument keyword: <code>(f :a :c)</code>, or make the default value a keyword:
|
||
|
|
<code>(define* (f (a :c) ...))</code>, or set <code>(*s7* 'accept-all-keyword-arguments)</code>
|
||
|
|
to some true value.
|
||
|
|
See s7test.scm for many examples.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>What if two functions share a keyword argument,
|
||
|
|
and one wants to call the other, passing both arguments to the wrapper?
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define* (f1 a) a) ; the wrappee
|
||
|
|
(define* (f2 a :rest b <em class="red">:allow-other-keys</em>) ; the wrapper
|
||
|
|
(+ a (apply f1 b)))
|
||
|
|
(f2 :a 3 :a 4) ; 7, b='(:a 4)
|
||
|
|
(let ((c :a))
|
||
|
|
(f2 c 3 c 4)) ; also 7
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Since named let* is a form of lambda*, the prohibition of repeated variable names makes it different
|
||
|
|
from let*: <code>(let* ((a 1) (a 2)) a)</code> is 2, but <code>(let* loop ((a 1) (a 2)) a)</code> is an error.
|
||
|
|
If let* and named let* agreed in this, we'd have an inconsistency with lambda*. If all three allowed repeated
|
||
|
|
variables, the decision as to which parameter is intended becomes messy: <code>((lambda* (a a) a) 2 :a 3)</code>,
|
||
|
|
or <code>(let* loop ((a 1) (a 2)) (loop 2 :a 3))</code>.
|
||
|
|
CL and standard scheme accept repeated variables in let*, so I think the current
|
||
|
|
choice is the least surprising.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>s7's lambda* arglist handling is not the same as CL's lambda-list. First,
|
||
|
|
you can have more than one :rest parameter:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> ((lambda* (:rest a :rest b) (map + a b)) 1 2 3 4 5)
|
||
|
|
<em class="gray">'(3 5 7 9)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>and second, the rest parameter, if any, takes up an argument slot just like any other
|
||
|
|
argument:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> ((lambda* ((b 3) :rest x (c 1)) (list b c x)) 32)
|
||
|
|
<em class="gray">(32 1 ())</em>
|
||
|
|
> ((lambda* ((b 3) :rest x (c 1)) (list b c x)) 1 2 3 4 5)
|
||
|
|
<em class="gray">(1 3 (2 3 4 5))</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>CL would agree with the first case if we used &key for 'c', but would give an error in the second.
|
||
|
|
Of course, the major difference is that s7 keyword arguments don't insist that the key be present.
|
||
|
|
The :rest argument is needed in cases like these because we can't use an expression
|
||
|
|
such as:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> ((lambda* ((a 3) . b c) (list a b c)) 1 2 3 4 5)
|
||
|
|
<em class="red">error</em><em class="gray">: stray dot?</em>
|
||
|
|
> ((lambda* (a . (b 1)) b) 1 2) ; the reader turns the arglist into (a b 1)
|
||
|
|
<em class="red">error</em><em class="gray">: lambda* parameter '1 is a constant</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Yet another nit: the :rest argument is not considered a keyword argument, so
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define* (f :rest a) a)
|
||
|
|
<em class="gray">f</em>
|
||
|
|
> (f :a 1)
|
||
|
|
<em class="gray">(:a 1)</em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<!--
|
||
|
|
unknown key handling is not good, :allow-key-values?
|
||
|
|
|
||
|
|
(define* (f1 a) (list a))
|
||
|
|
(f1 :hi) -> (:hi)
|
||
|
|
(f1 ':hi) -> (:hi)
|
||
|
|
(f1 :a :hi) -> (:hi)
|
||
|
|
|
||
|
|
(define* (f2 a :allow-other-keys) (list a))
|
||
|
|
(f2 :hi) -> (:hi)
|
||
|
|
|
||
|
|
(define* (f3 a b :allow-other-keys) (list a b))
|
||
|
|
(f3 :hi 0) -> (#f #f)
|
||
|
|
(f3 :hi) => (:hi #f)
|
||
|
|
|
||
|
|
(define* (f4 a) (list (symbol->keyword a))) ; or string->keyword
|
||
|
|
(f4 'hi) -> (:hi)
|
||
|
|
|
||
|
|
(define* (f5 a)
|
||
|
|
((lambda* (hi) (list hi)) (symbol->keyword a) 32))
|
||
|
|
(f5 'hi) -> (32)
|
||
|
|
|
||
|
|
(define* (f6 a b)
|
||
|
|
((lambda* (hi) (list hi)) a b))
|
||
|
|
(f6 :hi 1) -> unknown key :hi
|
||
|
|
|
||
|
|
(define* (f7 a b) (list a b))
|
||
|
|
(f7 :hi) -> (:hi #f)
|
||
|
|
(f7 0 :hi) -> (0 :hi)
|
||
|
|
(f7 :hi 0) -> unknown key
|
||
|
|
(f7 :a :hi) -> (:hi #f)
|
||
|
|
(f7 :a :hi 32) -> (:hi 32)
|
||
|
|
|
||
|
|
(define* (f8 a b)
|
||
|
|
((lambda* (hi ho) (list hi ho)) (symbol->keyword a) b))
|
||
|
|
(f8 'hi 32) -> (32 #f)
|
||
|
|
(f8 'ho 32) -> (#f 32)
|
||
|
|
|
||
|
|
|
||
|
|
another amusing lambda* case:
|
||
|
|
(call/cc
|
||
|
|
(lambda* (a (b (call/cc (lambda (c) c)))) ; even with-baffle still a loop (legit)
|
||
|
|
(b (call/cc (lambda (d) d)))))
|
||
|
|
|
||
|
|
;; equivalent to:
|
||
|
|
(let ((c (call/cc (lambda (c) c))))
|
||
|
|
(call/cc (lambda (a)
|
||
|
|
(c (call/cc (lambda (d) d))))))
|
||
|
|
-->
|
||
|
|
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="macros"><h4>macros</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<em class="def" id="definemacro">define-macro</em>,
|
||
|
|
<em class="def" id="definemacrostar">define-macro*</em>,
|
||
|
|
<em class="def" id="definebacro">define-bacro</em>,
|
||
|
|
<em class="def" id="definebacrostar">define-nacro*</em>,
|
||
|
|
<em class="def" id="macroexpand">macroexpand</em>,
|
||
|
|
<em class="def" id="gensym">gensym</em>,
|
||
|
|
<em class="def" id="gensym?">gensym?</em>, and
|
||
|
|
<em class="def" id="macrop">macro?</em>
|
||
|
|
implement the standard old-time macros.
|
||
|
|
The anonymous versions (analogous to lambda and lambda*) are
|
||
|
|
macro, macro*, bacro, and bacro*.
|
||
|
|
See s7test.scm for many examples of macros including such perennial favorites as
|
||
|
|
loop, dotimes, do*, enum, pushnew, and defstruct.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-macro (and-let* vars . body)
|
||
|
|
`(let ()
|
||
|
|
(and ,@(map (lambda (v)
|
||
|
|
`(define ,@v))
|
||
|
|
vars)
|
||
|
|
(begin ,@body))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>macroexpand can help debug a macro. I always forget that it
|
||
|
|
wants an expression:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-macro (add-1 arg) `(+ 1 ,arg))
|
||
|
|
<em class="gray">add-1</em>
|
||
|
|
> (macroexpand (add-1 32))
|
||
|
|
<em class="gray">(+ 1 32)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>gensym returns a symbol that is guaranteed to be unused. It takes an optional string argument
|
||
|
|
giving the new symbol name's prefix. gensym? returns #t if its argument is a symbol created by gensym.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define-macro (pop! sym)
|
||
|
|
(let ((v (<em class="red">gensym</em>)))
|
||
|
|
`(let ((,v (car ,sym)))
|
||
|
|
(set! ,sym (cdr ,sym))
|
||
|
|
,v)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>As in define*, the starred forms give optional and keyword arguments:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-macro* (add-2 a (b 2)) `(+ ,a ,b))
|
||
|
|
<em class="gray">add-2</em>
|
||
|
|
> (add-2 1 3)
|
||
|
|
<em class="gray">4</em>
|
||
|
|
> (add-2 1)
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (add-2 :b 3 :a 1)
|
||
|
|
<em class="gray">4</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>A macro is a first-class citizen of s7. You can
|
||
|
|
pass it as a function argument, apply it to a list, return it from a function,
|
||
|
|
call it recursively,
|
||
|
|
and assign it to a variable. You can even set its setter!
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-macro (hi a) `(+ ,a 1))
|
||
|
|
<em class="gray">hi</em>
|
||
|
|
> (apply hi '(4))
|
||
|
|
<em class="gray">5</em>
|
||
|
|
> (define (fmac mac) (apply mac '(4)))
|
||
|
|
<em class="gray">fmac</em>
|
||
|
|
> (fmac hi)
|
||
|
|
<em class="gray">5</em>
|
||
|
|
> (define (fmac mac) (mac 4))
|
||
|
|
<em class="gray">fmac</em>
|
||
|
|
> (fmac hi)
|
||
|
|
<em class="gray">5</em>
|
||
|
|
> (define (make-mac)
|
||
|
|
(define-macro (hi a) `(+ ,a 1)))
|
||
|
|
<em class="gray">make-mac</em>
|
||
|
|
> (let ((x (make-mac)))
|
||
|
|
(x 2))
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (define-macro (ref v i) `(vector-ref ,v ,i))
|
||
|
|
<em class="gray">ref</em>
|
||
|
|
> (define-macro (set v i x) `(vector-set! ,v ,i ,x))
|
||
|
|
<em class="gray">set</em>
|
||
|
|
> (set! (setter ref) set)
|
||
|
|
<em class="gray">set</em>
|
||
|
|
> (let ((v (vector 1 2 3))) (set! (ref v 0) 32) v)
|
||
|
|
<em class="gray">#(32 2 3)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>To expand all the macros in a piece of code:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define-macro (fully-macroexpand form)
|
||
|
|
(list 'quote
|
||
|
|
(let expand ((form form))
|
||
|
|
(cond ((not (pair? form)) form)
|
||
|
|
((and (symbol? (car form))
|
||
|
|
(macro? (symbol->value (car form))))
|
||
|
|
(expand (apply macroexpand (list form))))
|
||
|
|
((and (eq? (car form) 'set!) ; look for (set! (mac ...) ...) and use mac's setter
|
||
|
|
(pair? (cdr form))
|
||
|
|
(pair? (cadr form))
|
||
|
|
(macro? (symbol->value (caadr form))))
|
||
|
|
(expand (apply macroexpand (list (cons (setter (symbol->value (caadr form)))
|
||
|
|
(append (cdadr form) (copy (cddr form))))))))
|
||
|
|
(else (cons (expand (car form)) (expand (cdr form))))))))
|
||
|
|
</pre>
|
||
|
|
<p>This does not always handle bacros correctly because their expansion can depend on the run-time
|
||
|
|
state.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>A bacro is a macro that expands its body and evaluates
|
||
|
|
the result in the calling environment.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define setf
|
||
|
|
(let ((args (gensym))
|
||
|
|
(name (gensym)))
|
||
|
|
(apply <em class="red">define-bacro</em> `((,name . ,args)
|
||
|
|
(unless (null? ,args)
|
||
|
|
(apply set! (car ,args) (cadr ,args) ())
|
||
|
|
(apply setf (cddr ,args)))))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<p>
|
||
|
|
The setf argument is a gensym (created when setf is defined) so that its name does not shadow any existing
|
||
|
|
variable. Bacros expand in the calling environment, and a normal argument name
|
||
|
|
might shadow something in that environment while the bacro is being expanded.
|
||
|
|
Similarly, if you introduce bindings in the bacro expansion code, you need to
|
||
|
|
keep track of which environment you want things to happen in. Use with-let
|
||
|
|
and gensym liberally.
|
||
|
|
stuff.scm has bacro-shaker which can find inadvertent name collisions,
|
||
|
|
but it is flighty and easily confused.
|
||
|
|
The calling environment itself is (outlet (curlet)) from within a bacro, so
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define-bacro (holler)
|
||
|
|
`(format *stderr* "(~S~{ ~S ~S~^~})~%"
|
||
|
|
(let ((f (*function*)))
|
||
|
|
(if (pair? f) (car f) f))
|
||
|
|
(map (lambda (slot)
|
||
|
|
(values (symbol->keyword (car slot)) (cdr slot)))
|
||
|
|
(reverse (map values ,(outlet (curlet)))))))
|
||
|
|
|
||
|
|
(define (f1 a b)
|
||
|
|
(holler)
|
||
|
|
(+ a b))
|
||
|
|
|
||
|
|
(f1 2 3) ; prints out "(f1 :a 2 :b 3)" and returns 5
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
Since a bacro (normally) sheds its define-time environment:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define call-bac
|
||
|
|
(let ((<em class="red">x</em> 2))
|
||
|
|
(define-bacro (m a) `(+ ,a ,<em class="red">x</em>))))
|
||
|
|
|
||
|
|
> (call-bac 1)
|
||
|
|
<em class="red">error</em><em class="gray">: x: unbound variable</em>
|
||
|
|
</pre>
|
||
|
|
<p>
|
||
|
|
A macro here returns 3. But don't be hasty! The bacro can get its define-time environment (its closure)
|
||
|
|
via funclet, so in fact, define-macro is a special case of define-bacro! We can define
|
||
|
|
macros that work in all four ways: the expansion can happen in either the definition or calling environment,
|
||
|
|
as can the evaluation of that expansion. In a bacro, both happen in the calling environment
|
||
|
|
if we take no other action, and in a normal macro (define-macro), the expansion happens in the definition
|
||
|
|
environment, and the evaluation in the calling environment.
|
||
|
|
Here's a brief example of all four:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(let ((x 1) (y 2))
|
||
|
|
(define-bacro (bac1 a)
|
||
|
|
`(+ ,x y ,a)) ; expand and eval in calling env
|
||
|
|
(let ((x 32) (y 64))
|
||
|
|
(bac1 3))) ; (with-let (inlet 'x 32 'y 64) (+ 32 y 3))
|
||
|
|
-> 99 ; with-let and inlet refer to <a href="#environments">environments</a>
|
||
|
|
|
||
|
|
(let ((x 1) (y 2)) ; this is like define-macro
|
||
|
|
(define-bacro (bac2 a)
|
||
|
|
(with-let (sublet (funclet bac2) :a a)
|
||
|
|
`(+ ,x y ,a))) ; expand in definition env, eval in calling env
|
||
|
|
(let ((x 32) (y 64))
|
||
|
|
(bac2 3))) ; (with-let (inlet 'x 32 'y 64) (+ 1 y 3))
|
||
|
|
-> 68
|
||
|
|
|
||
|
|
(let ((x 1) (y 2))
|
||
|
|
(define-bacro (bac3 a)
|
||
|
|
(let ((e (with-let (sublet (funclet bac3) :a a)
|
||
|
|
`(+ ,x y ,a))))
|
||
|
|
`(with-let ,(sublet (funclet bac3) :a a)
|
||
|
|
,e))) ; expand and eval in definition env
|
||
|
|
(let ((x 32) (y 64))
|
||
|
|
(bac3 3))) ; (with-let (inlet 'x 1 'y 2) (+ 1 y 3))
|
||
|
|
-> 6
|
||
|
|
|
||
|
|
(let ((x 1) (y 2))
|
||
|
|
(define-bacro (bac4 a)
|
||
|
|
(let ((e `(+ ,x y ,a)))
|
||
|
|
`(with-let ,(sublet (funclet bac4) :a a)
|
||
|
|
,e))) ; expand in calling env, eval in definition env
|
||
|
|
(let ((x 32) (y 64))
|
||
|
|
(bac4 3))) ; (with-let (inlet 'x 1 'y 2) (+ 32 y 3))
|
||
|
|
-> 37
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Backquote (quasiquote) in s7 is almost trivial. Constants are unchanged, symbols are quoted,
|
||
|
|
",arg" becomes "arg", and ",@arg" becomes "(apply values arg)" — hooray for real multiple values!
|
||
|
|
It's almost as easy to write the actual macro body as the backquoted version of it.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-macro (hi a) `(+ 1 ,a))
|
||
|
|
<em class="gray">hi</em>
|
||
|
|
> (procedure-source hi)
|
||
|
|
<em class="gray">(lambda (a) (list-values '+ 1 a))</em>
|
||
|
|
|
||
|
|
> (define-macro (hi a) `(+ 1 ,@a))
|
||
|
|
<em class="gray">hi</em>
|
||
|
|
> (procedure-source hi)
|
||
|
|
<em class="gray">(lambda (a) (list-values '+ 1 (apply-values a)))</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>list-values and apply-values are quasiquote helper functions described <a href="#listvalues">below</a>.
|
||
|
|
There is no unquote-splicing
|
||
|
|
macro in s7; ",@(...)" becomes "(unquote (apply-values ...))" at read-time. There shouldn't be any unquote
|
||
|
|
either. In Scheme the reader turns ,x into (unquote x), so:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre>> (let (,'a) unquote)
|
||
|
|
<em class="gray">a</em>
|
||
|
|
> (let (, (lambda (x) (+ x 1))) ,,,,'3)
|
||
|
|
<em class="gray">7</em>
|
||
|
|
</pre>
|
||
|
|
<p>comma becomes a sort of symbol macro! I think I'll remove unquote; ,x
|
||
|
|
and ,@x will still work
|
||
|
|
as expected, but there will not be any "unquote" or "unquote-splicing"
|
||
|
|
in the resultant source code. Just to make life difficult:
|
||
|
|
</p>
|
||
|
|
<pre>> (let (' 1) quote)
|
||
|
|
<em class="gray">1</em>
|
||
|
|
</pre>
|
||
|
|
<p>but that translation is so ingrained in lisp
|
||
|
|
that I'm reluctant to change it. The two unquote names, on the
|
||
|
|
other hand, seem unnecessary.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
<p>s7 macros are not hygienic. For example,
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-macro (mac b)
|
||
|
|
`(let ((a 12))
|
||
|
|
(+ a ,b)))
|
||
|
|
<em class="gray">mac</em>
|
||
|
|
> (let ((a 1) (+ *)) (mac a))
|
||
|
|
<em class="gray">144</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>This returns 144 because '+' has turned into '*', and 'a' is the internal 'a',
|
||
|
|
not the argument 'a'. We get <code>(* 12 12)</code> where we might have expected
|
||
|
|
<code>(+ 12 1)</code>.
|
||
|
|
Starting with the '+' problem,
|
||
|
|
as long as the redefinition of '+' is local (that is, it happens after the macro definition), we can unquote the +:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-macro (mac b)
|
||
|
|
`(let ((a 12))
|
||
|
|
(,+ a ,b))) ; ,+ picks up the definition-time +
|
||
|
|
<em class="gray">mac</em>
|
||
|
|
> (let ((a 1) (+ *)) (mac a))
|
||
|
|
<em class="gray">24 ; (+ a a) where a is 12</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>But the unquote trick won't work if we have previously loaded some file that redefined '+'
|
||
|
|
at the top-level (so at macro definition time, + is *, but we want the built-in +).
|
||
|
|
Although this example is silly, the problem is real in Scheme
|
||
|
|
because Scheme has no reserved words and only one name space.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define + *)
|
||
|
|
<em class="gray">+</em>
|
||
|
|
> (define (add a b) (+ a b))
|
||
|
|
<em class="gray">add</em>
|
||
|
|
> (add 2 3)
|
||
|
|
<em class="gray">6</em>
|
||
|
|
> (define (divide a b) (/ a b))
|
||
|
|
<em class="gray">divide</em>
|
||
|
|
> (divide 2 3)
|
||
|
|
<em class="gray">2/3</em>
|
||
|
|
> (set! / -) ; a bad idea — this turns off s7's optimizer
|
||
|
|
<em class="gray">-</em>
|
||
|
|
> (divide 2 3)
|
||
|
|
<em class="gray">-1</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Obviously macros are not the problem here. Since
|
||
|
|
we might be loading
|
||
|
|
code written by others, it's sometimes hard to tell what names
|
||
|
|
that code depends on or redefines.
|
||
|
|
We need a way to get the pristine (start-up, built-in) value of '+'.
|
||
|
|
One long-winded way in s7 uses <a href="#unlet">unlet</a>:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define + *)
|
||
|
|
<em class="gray">+</em>
|
||
|
|
> (define (add a b) (with-let (unlet) (+ a b)))
|
||
|
|
<em class="gray">add</em>
|
||
|
|
> (add 2 3)
|
||
|
|
<em class="gray">5</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>But this is hard to read, and we might want all three
|
||
|
|
values of a symbol, the start-up value, the definition-time value, and the
|
||
|
|
current value. The latter can be accessed with the bare symbol, the definition-time
|
||
|
|
value with unquote (','), and the start-up value with either unlet
|
||
|
|
or #_<name>. That is, #_+ is a reader macro for <code>(with-let (unlet) +)</code>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-macro (mac b)
|
||
|
|
`(<em class="red">#_let</em> ((a 12))
|
||
|
|
(<em class="red">#_+</em> a ,b))) ; #_+ and #_let are start-up values
|
||
|
|
<em class="gray">mac</em>
|
||
|
|
> (let ((a 1) (+ *)) (mac a))
|
||
|
|
<em class="gray">24 ; (+ a a) where a is 12 and + is the start-up +</em>
|
||
|
|
|
||
|
|
;;; make + generic (there's a similar C-based example below)
|
||
|
|
> (define (+ . args)
|
||
|
|
(if (null? args) 0
|
||
|
|
(apply (if (number? (car args)) <em class="red">#_+ #_string-append</em>) args)))
|
||
|
|
<em class="gray">+</em>
|
||
|
|
> (+ 1 2)
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (+ "hi" "ho")
|
||
|
|
<em class="gray">"hiho"</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<p>Conceptually, #_<name> could be implemented via *#readers*:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(set! *#readers*
|
||
|
|
(cons (cons #\_ (lambda (str)
|
||
|
|
(with-let (unlet)
|
||
|
|
(string->symbol (substring str 1)))))
|
||
|
|
*#readers*))
|
||
|
|
</pre>
|
||
|
|
<p>but s7 doesn't let you change the meaning of #\_; otherwise:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(set! *#readers* (list (cons #\_ (lambda (str) (string->symbol (substring str 1))))))
|
||
|
|
</pre>
|
||
|
|
<p>and now #_ provides no protection:
|
||
|
|
</p>
|
||
|
|
<pre>> (let ((+ -)) (#_+ 1 2))
|
||
|
|
<em class="gray">-1</em>
|
||
|
|
</pre>
|
||
|
|
<p>#t and #f (along with their stupid r7rs cousins #true and #false) are also not settable.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
So, now we have only the variable capture problem ('a' has been captured in the preceding examples).
|
||
|
|
This is the only thing that the gigantic "hygienic macro" systems actually deal with:
|
||
|
|
a microscopic problem that you'd think, from the hype, was up there with malaria and the
|
||
|
|
national debt. gensym is the standard approach:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-macro (mac b)
|
||
|
|
(let ((var (<em class="red">gensym</em>)))
|
||
|
|
`(#_let ((,var 12))
|
||
|
|
(#_+ ,var ,b))))
|
||
|
|
<em class="gray">mac</em>
|
||
|
|
> (let ((a 1) (+ *)) (mac a))
|
||
|
|
<em class="gray">13</em>
|
||
|
|
|
||
|
|
;; or use lambda:
|
||
|
|
> (define-macro (mac b)
|
||
|
|
`((lambda (b) (let ((a 12)) (#_+ a b))) ,b))
|
||
|
|
<em class="gray">mac</em>
|
||
|
|
> (let ((a 1) (+ *)) (mac a))
|
||
|
|
<em class="gray">13</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>I think syntax-rules and its friends try to conjure up gensyms automatically, but
|
||
|
|
the real problem is not name collisions, but unspecified environments.
|
||
|
|
In s7 we have first-class environments, so you have complete
|
||
|
|
control over the environment at any point:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre>(define-macro (mac b)
|
||
|
|
`(with-let (inlet 'b ,b)
|
||
|
|
(let ((a 12))
|
||
|
|
(+ a b))))
|
||
|
|
|
||
|
|
> (let ((a 1) (+ *)) (mac a))
|
||
|
|
<em class="gray">13</em>
|
||
|
|
|
||
|
|
(define-macro (mac1 . b) ; originally `(let ((a 12)) (+ a ,@b ,@b))
|
||
|
|
`(with-let (inlet 'e (curlet)) ; this 'e will not collide with the calling env
|
||
|
|
(let ((a 12)) ; nor will 'a (so no gensyms are needed etc)
|
||
|
|
(+ a (with-let e ,@b) (with-let e ,@b)))))
|
||
|
|
|
||
|
|
> (let ((a 1) (e 2)) (mac1 (display a) (+ a e)))
|
||
|
|
<em class="gray">18</em> ; (and it displays "11")
|
||
|
|
|
||
|
|
(define-macro (mac2 x) ; this will use mac2's definition environment for its body
|
||
|
|
`(with-let (sublet (funclet mac2) :x ,x)
|
||
|
|
(let ((a 12))
|
||
|
|
(+ a b x)))) ; a is always 12, b is whatever b happens to be in mac2's env
|
||
|
|
|
||
|
|
> (define b 10) ; this is mac2's b
|
||
|
|
<em class="gray">10</em>
|
||
|
|
> (let ((+ *) (a 1) (b 15)) (mac2 (+ a b)))
|
||
|
|
<em class="gray">37</em> ; mac2 uses its own a (12), b (10), and + (+)
|
||
|
|
; but (+ a b) is 15 because at that point + is *: (* 1 15)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Hygienic macros are trivial! Who needs syntax-rules?
|
||
|
|
To avoid the variable capture, avoid local variables in the generated code, or
|
||
|
|
protect them via with-let; to avoid shadowing of functions and syntax, make the
|
||
|
|
environment explicit (via #_ for example).
|
||
|
|
s7's lint.scm will warn you about a problematic macro expansion, so I'd
|
||
|
|
say just write macros as simply as possible, then let lint tell you
|
||
|
|
that it's time to do the with-let shuffle. When that happens, wrap the macro body in
|
||
|
|
a with-let that captures the current environment, and at each use of a macro argument
|
||
|
|
wrap it in a with-let that re-establishes that environment.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<pre>(define-macro (swap a b) ; assume a and b are symbols
|
||
|
|
`(with-let (inlet 'e (curlet) 'tmp ,a)
|
||
|
|
(set! (e ',a) (e ',b))
|
||
|
|
(set! (e ',b) tmp)))
|
||
|
|
|
||
|
|
> (let ((b 1) (tmp 2)) (swap b tmp) (list b tmp))
|
||
|
|
<em class="gray">(2 1)</em>
|
||
|
|
|
||
|
|
(define-macro (swap a b) ; here a and b can be any settable expressions
|
||
|
|
`(set! ,b (with-let (inlet 'e (curlet) 'tmp ,a)
|
||
|
|
(with-let e (set! ,a ,b))
|
||
|
|
tmp)))
|
||
|
|
|
||
|
|
> (let ((v (vector 1 2))) (swap (v 0) (v 1)) v)
|
||
|
|
<em class="gray">#(2 1)</em>
|
||
|
|
> (let ((tmp (cons 1 2))) (swap (car tmp) (cdr tmp)) tmp)
|
||
|
|
<em class="gray">(2 . 1)</em>
|
||
|
|
|
||
|
|
(set! (setter swap) (define-macro (set-swap a b c) `(set! ,b ,c)))
|
||
|
|
|
||
|
|
> (let ((a 1) (b 2) (c 3) (d 4)) (swap a (swap b (swap c d))) (list a b c d))
|
||
|
|
<em class="gray">(2 3 4 1)</em>
|
||
|
|
|
||
|
|
;;; but this is simpler:
|
||
|
|
(define-macro (rotate! . args)
|
||
|
|
`(set! ,(args (- (length args) 1))
|
||
|
|
(with-let (inlet 'e (curlet) 'tmp ,(car args))
|
||
|
|
(with-let e
|
||
|
|
,@(map (lambda (a b) `(set! ,a ,b)) args (cdr args)))
|
||
|
|
tmp)))
|
||
|
|
|
||
|
|
> (let ((a 1) (b 2) (c 3)) (rotate! a b c) (list a b c))
|
||
|
|
<em class="gray">(2 3 1)</em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
If you want the macro's expanded result
|
||
|
|
to be evaluated in its definition environment:
|
||
|
|
</p>
|
||
|
|
<pre>(let ((a 3))
|
||
|
|
(define-macro (mac b)
|
||
|
|
`(with-let (inlet 'b ,b (funclet mac))
|
||
|
|
(+ a b))) ; definition-time "a", call-time "b"
|
||
|
|
(define-macro (mac-1 b)
|
||
|
|
`(+ a ,b)) ; call-time "a" and "b"
|
||
|
|
(let ((a 32))
|
||
|
|
(list (mac 1)
|
||
|
|
(mac-1 1))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<p>Here are some variations on "unless", inspired by the wikipedia hygienic macro page:
|
||
|
|
</p>
|
||
|
|
<pre>(define-macro (my-unless condition . body)
|
||
|
|
`(with-let (inlet (unlet) :condition ,condition) ; here unlet protects body (format below)
|
||
|
|
(if (not condition) (begin ,@body))))
|
||
|
|
|
||
|
|
(let ((not (lambda (x) x))
|
||
|
|
(begin 32)
|
||
|
|
(if +)
|
||
|
|
(format abs))
|
||
|
|
(my-unless #t (format #t "This should not be printed!\n"))
|
||
|
|
(my-unless #f (format #t "This should be printed!\n")))
|
||
|
|
|
||
|
|
(set! format abs)
|
||
|
|
(let ((not (lambda (x) x)))
|
||
|
|
(my-unless #t (format #t "This should not be printed!\n"))
|
||
|
|
(my-unless #f (format #t "This should be printed!\n")))
|
||
|
|
|
||
|
|
(define (user-defined-operator x) (not x))
|
||
|
|
|
||
|
|
(define-macro (my-unless-1 condition . body)
|
||
|
|
`(with-let (inlet (unlet) :condition ,condition)
|
||
|
|
(if (user-defined-operator condition) (begin ,@body))))
|
||
|
|
|
||
|
|
(let ((user-defined-operator (lambda (x) x)))
|
||
|
|
(my-unless-1 #t (format #t "This should not be printed!\n"))
|
||
|
|
(my-unless-1 #f (format #t "This should be printed!\n")))
|
||
|
|
|
||
|
|
(define my-unless-2
|
||
|
|
(let ((op1 (lambda (x) (not x))))
|
||
|
|
(define-macro (_ condition . body)
|
||
|
|
`(with-let (inlet (unlet) (funclet my-unless-2) :condition ,condition)
|
||
|
|
;; funclet above to get my-unless-2's version of op1
|
||
|
|
(if (op1 condition) (begin ,@body))))))
|
||
|
|
|
||
|
|
(let ((op1 (lambda (x) x)))
|
||
|
|
(my-unless-2 #t (format #t "This should not be printed!\n"))
|
||
|
|
(my-unless-2 #f (format #t "This should be printed!\n")))
|
||
|
|
|
||
|
|
(define my-unless-3
|
||
|
|
(let ((op1 (lambda (x) x)))
|
||
|
|
(define-macro (_ condition . body)
|
||
|
|
`(with-let (inlet (unlet) :condition ,condition :local-env (curlet))
|
||
|
|
;; curlet to get run-time local version of op1
|
||
|
|
(if ((with-let local-env op1) condition) (begin ,@body))))))
|
||
|
|
|
||
|
|
(let ((op1 (lambda (x) (not x))))
|
||
|
|
(my-unless-3 #t (format #t "This should not be printed!\n"))
|
||
|
|
(my-unless-3 #f (format #t "This should be printed!\n")))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
<!--
|
||
|
|
(define (tree-quote tree args)
|
||
|
|
(if (pair? tree)
|
||
|
|
(if (eq? (car tree) 'quote)
|
||
|
|
tree
|
||
|
|
(cons (tree-quote (car tree) args)
|
||
|
|
(tree-quote (cdr tree) args)))
|
||
|
|
(if (memq tree args)
|
||
|
|
(list 'quote tree)
|
||
|
|
tree)))
|
||
|
|
|
||
|
|
(define-macro (define-hacro name-and-args . body)
|
||
|
|
(let ((name (car name-and-args))
|
||
|
|
(args (cdr name-and-args)))
|
||
|
|
`(define-macro ,name-and-args
|
||
|
|
(list 'with-let
|
||
|
|
(list 'inlet ,@(map (lambda (arg)
|
||
|
|
(values (symbol->keyword arg) arg))
|
||
|
|
args))
|
||
|
|
,@(tree-quote body args)))))
|
||
|
|
|
||
|
|
; (define-hacro (mac a b) `(+ ,a ,b))
|
||
|
|
; (macroexpand (mac 2 3))
|
||
|
|
; (with-let (inlet :a 2 :b 3) (+ a b))
|
||
|
|
; (procedure-source mac)
|
||
|
|
; (lambda (a b) (list 'with-let (list 'inlet :a a :b b) (list-values '+ 'a 'b)))
|
||
|
|
-->
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<p>On the subject of *#readers*, say we have:
|
||
|
|
</p>
|
||
|
|
<pre>(set! *#readers* (list (cons #\o (lambda (str) 42)) ; #o... -> 42
|
||
|
|
(cons #\x (lambda (str) 3)))) ; #x... -> 3
|
||
|
|
</pre>
|
||
|
|
<p>Now we load a file with:
|
||
|
|
</p>
|
||
|
|
<pre>(define (oct) #o123)
|
||
|
|
|
||
|
|
(let-temporarily ((*#readers* ()))
|
||
|
|
(eval (with-input-from-string "(define (hex) #x123)" read)))
|
||
|
|
|
||
|
|
(define-constant old-readers *#readers*)
|
||
|
|
(set! *#readers* ())
|
||
|
|
|
||
|
|
(define (oct1) #o123)
|
||
|
|
(define (hex1) #x123)
|
||
|
|
|
||
|
|
(set! *#readers* old-readers)
|
||
|
|
|
||
|
|
(define (oct2) #o123)
|
||
|
|
(define (hex2) #x123)
|
||
|
|
</pre>
|
||
|
|
<p>Now we evaluate these functions, and get:
|
||
|
|
</p>
|
||
|
|
<pre>(oct): 42 ; oct is not read-time hygienic so #o123 -> 42
|
||
|
|
(oct1): 83 ; oct1 is protected by the top-level set, #o123 -> 83
|
||
|
|
(oct2): 42 ; same as oct
|
||
|
|
(hex): 291 ; hex is protected by let-temporarily + read
|
||
|
|
(hex1): 291 ; hex1 is like oct1
|
||
|
|
(hex2): 3 ; hex2 is like oct
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Here is Peter Seibel's wonderful once-only macro:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define-macro (once-only names . body)
|
||
|
|
(let ((gensyms (map (lambda (n) (gensym)) names)))
|
||
|
|
`(let (,@(map (lambda (g) (list g '(gensym))) gensyms))
|
||
|
|
`(let (,,@(map (lambda (g n) (list list g n)) gensyms names))
|
||
|
|
,(let (,@(map list names gensyms))
|
||
|
|
,@body)))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<!-- this was:
|
||
|
|
(define-macro (once-only names . body)
|
||
|
|
(let ((gensyms (map (lambda (n) (gensym)) names)))
|
||
|
|
`(let (,@(map (lambda (g) `(,g (gensym))) gensyms))
|
||
|
|
`(let (,,@(map (lambda (g n) ``(,,g ,,n)) gensyms names))
|
||
|
|
,(let (,@(map (lambda (n g) `(,n ,g)) names gensyms))
|
||
|
|
,@body)))))
|
||
|
|
-->
|
||
|
|
|
||
|
|
<p>From the land of sparkling bacros:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define once-only
|
||
|
|
(let ((names (gensym))
|
||
|
|
(body (gensym)))
|
||
|
|
(apply define-bacro `((,(gensym) ,names . ,body)
|
||
|
|
`(let (,@(map (lambda (name) `(,name ,(eval name))) ,names))
|
||
|
|
,@,body)))))
|
||
|
|
</pre>
|
||
|
|
<p>Sadly, with-let is simpler.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
<!--
|
||
|
|
when is (define-macro (f a) `(+ ,a 1)) not the same as (define (f a) (+ a 1))?
|
||
|
|
(f (values 2 3))
|
||
|
|
(f most-positive-fixnum) but only because the optimizer messes this up
|
||
|
|
-->
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="pws"><h4>setter</h4></div>
|
||
|
|
|
||
|
|
<pre class="indented">(<em class="def">setter</em> proc)
|
||
|
|
(<em class="def" id="dilambda">dilambda</em> proc setter)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>There are several kinds of setters, reflecting the many ways that set! can be called.
|
||
|
|
First are the symbol setters:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((x 1))
|
||
|
|
(set! (setter 'x) (lambda (name new-value) (* new-value 2)))
|
||
|
|
(set! x 2)
|
||
|
|
x)
|
||
|
|
<em class="gray">4</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Here the setter is a function that is called before the variable is set.
|
||
|
|
It can take two or three arguments. In the two argument case shown above,
|
||
|
|
the first is the variable name (a symbol), and the second is the new-value.
|
||
|
|
The variable is set to the value returned by the setter function.
|
||
|
|
When s7 sees <code>(set! x 2)</code> above, it calls the setter which returns 4.
|
||
|
|
So x is set to 4.
|
||
|
|
</p>
|
||
|
|
<p>In some cases you need the environment that the variable lives in (to get its
|
||
|
|
current value for example), so you can include that in the setter function parameter list:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((x 1))
|
||
|
|
(set! (setter 'x) (lambda (name new-value enviroment) (* new-value 2)))
|
||
|
|
(set! x 2)
|
||
|
|
x)
|
||
|
|
<em class="gray">4</em>
|
||
|
|
|
||
|
|
(define-macro (watch var) ; notification if 'var is set!
|
||
|
|
`(set! (setter ',var)
|
||
|
|
(lambda (s v e)
|
||
|
|
(format *stderr* "~S set! to ~S~A~%" s v
|
||
|
|
(let ((func (with-let e (*function*))))
|
||
|
|
(if (eq? func #<undefined>) "" (format #f ", ~S" func))))
|
||
|
|
v)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Since symbol setters are often implementing type restrictions, you can use
|
||
|
|
the built-in type checking functions such as integer? as a short-hand
|
||
|
|
for a setter that insists the new value be an integer:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((x 1))
|
||
|
|
(set! (setter 'x) integer?)
|
||
|
|
(set! x 3.14))
|
||
|
|
<em class="red">error</em><em class="gray">: set! x: 3.14, is a real but should be an integer</em>
|
||
|
|
|
||
|
|
;;; use typed-let from stuff.scm to do the same thing:
|
||
|
|
> (typed-let ((x 3 integer?))
|
||
|
|
(set! x 3.14))
|
||
|
|
<em class="red">error</em><em class="gray">: set! x: 3.14, is a real but should be an integer</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>C-side symbol setters go through s7_set_setter. There is an example <a href="#notify">below</a>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<p>The second case is a function setter. Almost any function or macro can
|
||
|
|
have an associated setter that is invoked when the function is the target of set!.
|
||
|
|
In this case, the setter function does the set! itself (unlike a symbol setter):
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (setter cadr)
|
||
|
|
<em class="gray">#f</em> ; by default cadr has no setter so (set! (cadr p) x) is an error
|
||
|
|
> (set! (setter cadr) ; add a setter to cadr
|
||
|
|
(lambda (lst val)
|
||
|
|
(set! (car (cdr lst)) val)))
|
||
|
|
<em class="gray">#<lambda (lst val)></em>
|
||
|
|
> (procedure-source (setter cadr))
|
||
|
|
<em class="gray">(lambda (lst val) (set! (car (cdr lst)) val))</em>
|
||
|
|
> (let ((lst (list 1 2 3)))
|
||
|
|
(set! (cadr lst) 4)
|
||
|
|
lst)
|
||
|
|
<em class="gray">(1 4 3)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>In some cases, the setter needs to be a macro:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (set! (setter logbit?)
|
||
|
|
(define-macro (m var index on) ; here we want to set "var", so we need a macro
|
||
|
|
`(if ,on
|
||
|
|
(set! ,var (logior ,var (ash 1 ,index)))
|
||
|
|
(set! ,var (logand ,var (lognot (ash 1 ,index)))))))
|
||
|
|
<em class="gray">m</em>
|
||
|
|
> (define (mingle a b)
|
||
|
|
(let ((r 0))
|
||
|
|
(do ((i 0 (+ i 1)))
|
||
|
|
((= i 31) r)
|
||
|
|
(set! (logbit? r (* 2 i)) (logbit? a i))
|
||
|
|
(set! (logbit? r (+ (* 2 i) 1)) (logbit? b i)))))
|
||
|
|
<em class="gray">mingle</em>
|
||
|
|
> (mingle 6 3) ; the INTERCAL mingle operator?
|
||
|
|
<em class="gray">30</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>dilambda defines a function (or macro) and its setter without having to set! the setter by hand:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define f (let ((x 123))
|
||
|
|
(dilambda (lambda ()
|
||
|
|
x)
|
||
|
|
(lambda (new-value)
|
||
|
|
(set! x new-value)))))
|
||
|
|
<em class="gray">f</em>
|
||
|
|
> (f)
|
||
|
|
<em class="gray">123</em> ; x = 123
|
||
|
|
> (set! (f) 32)
|
||
|
|
<em class="gray">32</em> ; now x = 32
|
||
|
|
> (f)
|
||
|
|
<em class="gray">32</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Here is a pretty example of dilambda:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define-macro (c?r path)
|
||
|
|
;; "path" is a list and "X" marks the spot in it that we are trying to access
|
||
|
|
;; (a (b ((c X)))) — anything after the X is ignored, other symbols are just placeholders
|
||
|
|
;; c?r returns a dilambda that gets/sets X
|
||
|
|
|
||
|
|
(define (X-marks-the-spot accessor tree)
|
||
|
|
(if (eq? tree 'X)
|
||
|
|
accessor
|
||
|
|
(and (pair? tree)
|
||
|
|
(or (X-marks-the-spot (cons 'car accessor) (car tree))
|
||
|
|
(X-marks-the-spot (cons 'cdr accessor) (cdr tree))))))
|
||
|
|
|
||
|
|
(let ((body 'lst))
|
||
|
|
(for-each
|
||
|
|
(lambda (f)
|
||
|
|
(set! body (list f body)))
|
||
|
|
(reverse (X-marks-the-spot () path)))
|
||
|
|
|
||
|
|
`(<em class="red">dilambda</em>
|
||
|
|
(lambda (lst)
|
||
|
|
,body)
|
||
|
|
(lambda (lst val)
|
||
|
|
(set! ,body val)))))
|
||
|
|
|
||
|
|
> ((c?r (a b (X))) '(1 2 (3 4) 5))
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (let ((lst (list 1 2 (list 3 4) 5)))
|
||
|
|
(set! ((c?r (a b (X))) lst) 32)
|
||
|
|
lst)
|
||
|
|
<em class="gray">(1 2 (32 4) 5)</em>
|
||
|
|
> (procedure-source (c?r (a b (X))))
|
||
|
|
<em class="gray">(lambda (lst) (car (car (cdr (cdr lst)))))</em>
|
||
|
|
> ((c?r (a b . X)) '(1 2 (3 4) 5))
|
||
|
|
<em class="gray">((3 4) 5)</em>
|
||
|
|
> (let ((lst (list 1 2 (list 3 4) 5)))
|
||
|
|
(set! ((c?r (a b . X)) lst) '(32))
|
||
|
|
lst)
|
||
|
|
<em class="gray">(1 2 32)</em>
|
||
|
|
> (procedure-source (c?r (a b . X)))
|
||
|
|
<em class="gray">(lambda (lst) (cdr (cdr lst)))</em>
|
||
|
|
> ((c?r (((((a (b (c (d (e X)))))))))) '(((((1 (2 (3 (4 (5 6))))))))))
|
||
|
|
<em class="gray">6</em>
|
||
|
|
> (let ((lst '(((((1 (2 (3 (4 (5 6)))))))))))
|
||
|
|
(set! ((c?r (((((a (b (c (d (e X)))))))))) lst) 32)
|
||
|
|
lst)
|
||
|
|
<em class="gray">(((((1 (2 (3 (4 (5 32)))))))))</em>
|
||
|
|
> (procedure-source (c?r (((((a (b (c (d (e X)))))))))))
|
||
|
|
<em class="gray">(lambda (lst) (car (cdr (car (cdr (car (cdr (car (cdr (car (cdr (car (car (car (car lst)))))))))))))))</em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<p>I may remove dilambda and dilambda? someday; they are trivial:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define (dilambda get set) (set! (setter get) set) get)
|
||
|
|
(define dilambda? setter)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>When a function setter is called, <code>(set! (func ...) val)</code> is
|
||
|
|
evaluated by s7 as <code>((setter func) ... val)</code>, so the setter function
|
||
|
|
needs to handle both the inner arguments to the function and the new value.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(let ((x 123))
|
||
|
|
(define (f a b) (+ x a b))
|
||
|
|
(set! (setter f) (lambda (a b val) (set! x val)))
|
||
|
|
(display (f 1 2)) (newline) ; "126"
|
||
|
|
(set! (f 1 2) 32)
|
||
|
|
(display (f 1 2)) (newline)) ; "35"
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>A third type of setter handles vector element type and hash-table key and value types.
|
||
|
|
These are described under <a href="#typedvectors">typed vectors</a> and
|
||
|
|
<a href="#typedhash">typed hash-tables</a>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<br>
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<p>Speaking of INTERCAL, COME-FROM:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define-macro (define-with-goto-and-come-from name-and-args . body)
|
||
|
|
(let ((labels ())
|
||
|
|
(gotos ())
|
||
|
|
(come-froms ()))
|
||
|
|
|
||
|
|
(let collect-jumps ((tree body))
|
||
|
|
(when (pair? tree)
|
||
|
|
(when (pair? (car tree))
|
||
|
|
(case (caar tree)
|
||
|
|
((label) (set! labels (cons tree labels)))
|
||
|
|
((goto) (set! gotos (cons tree gotos)))
|
||
|
|
((come-from) (set! come-froms (cons tree come-froms)))
|
||
|
|
(else (collect-jumps (car tree)))))
|
||
|
|
(collect-jumps (cdr tree))))
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(lambda (goto)
|
||
|
|
(let* ((name (cadr (cadar goto)))
|
||
|
|
(label (member name labels (lambda (a b) (eq? a (cadr (cadar b)))))))
|
||
|
|
(if label
|
||
|
|
(set-cdr! goto (car label))
|
||
|
|
(error 'bad-goto "can't find label: ~S" name))))
|
||
|
|
gotos)
|
||
|
|
|
||
|
|
(for-each
|
||
|
|
(lambda (from)
|
||
|
|
(let* ((name (cadr (cadar from)))
|
||
|
|
(label (member name labels (lambda (a b) (eq? a (cadr (cadar b)))))))
|
||
|
|
(if label
|
||
|
|
(set-cdr! (car label) from)
|
||
|
|
(error 'bad-come-from "can't find label: ~S" name))))
|
||
|
|
come-froms)
|
||
|
|
|
||
|
|
`(define ,name-and-args
|
||
|
|
(let ((label (lambda (name) #f))
|
||
|
|
(goto (lambda (name) #f))
|
||
|
|
(come-from (lambda (name) #f)))
|
||
|
|
,@body))))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
<!-- (define-macro (please . args) args) -->
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="generalizedset"><h4>applicable objects, generalized set!, generic functions</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<p>A procedure with a setter can be viewed as one generalization of set!. Another
|
||
|
|
treats objects as having predefined get and set functions. In s7
|
||
|
|
lists, strings, vectors, hash-tables, environments, and any cooperating C or Scheme-defined objects
|
||
|
|
are both applicable and settable. newLisp calls this implicit indexing, Kawa has it, Gauche implements it
|
||
|
|
via object-apply, Guile via procedure-with-setter; CL's funcallable instance might be the same idea.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
In <code>(vector-ref #(1 2) 0)</code>, for example, vector-ref is just a type
|
||
|
|
declaration. But in Scheme, type declarations are unnecessary, so we get exactly
|
||
|
|
the same result from <code>(#(1 2) 0)</code>. Similarly, <code>(lst 1)</code> is the
|
||
|
|
same as <code>(list-ref lst 1)</code>, and <code>(set! (lst 1) 2)</code> is the same
|
||
|
|
as <code>(list-set! lst 1 2)</code>.
|
||
|
|
I like this syntax: the less noise, the better!
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Well, maybe applicable strings look weird: <code>("hi" 1)</code> is #\i, but worse,
|
||
|
|
so is <code>(cond (1 => "hi"))</code>! Even though a string, list, or vector is "applicable", it is
|
||
|
|
not currently considered to be a procedure, so <code>(procedure? "hi")</code> is #f. map and for-each, however,
|
||
|
|
accept anything that apply can handle, so
|
||
|
|
<code>(map #(0 1) '(1 0))</code> is '(1 0). (On the first call to map in this case, you get the result of
|
||
|
|
<code>(#(0 1) 1)</code> and so on).
|
||
|
|
string->list, vector->list, and let->list are <code>(map values object)</code>.
|
||
|
|
Their inverses are (and always have been) equally trivial.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<p>The applicable object syntax makes it easy to write generic functions.
|
||
|
|
For example, s7test.scm has implementations of Common Lisp's sequence functions.
|
||
|
|
length, copy, reverse, fill!, iterate, map and for-each are generic in this sense (map always returns a list).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (map (lambda (a b) (- a b)) (list 1 2) (vector 3 4))
|
||
|
|
<em class="gray">(5 -3 9)</em>
|
||
|
|
> (length "hi")
|
||
|
|
<em class="gray">2</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
Here's a generic FFT:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define* (cfft data n (dir 1)) ; complex data
|
||
|
|
(unless n (set! n (length data)))
|
||
|
|
(do ((i 0 (+ i 1))
|
||
|
|
(j 0))
|
||
|
|
((= i n))
|
||
|
|
(if (> j i)
|
||
|
|
(let ((temp (data j)))
|
||
|
|
(set! (data j) (data i))
|
||
|
|
(set! (data i) temp)))
|
||
|
|
(do ((m (/ n 2) (/ m 2)))
|
||
|
|
((not (<= 2 m j))
|
||
|
|
(set! j (+ j m)))
|
||
|
|
(set! j (- j m))))
|
||
|
|
(do ((ipow (floor (log n 2)))
|
||
|
|
(prev 1)
|
||
|
|
(lg 0 (+ lg 1))
|
||
|
|
(mmax 2 (* mmax 2))
|
||
|
|
(pow (/ n 2) (/ pow 2))
|
||
|
|
(theta (complex 0.0 (* pi dir)) (* theta 0.5)))
|
||
|
|
((= lg ipow))
|
||
|
|
(do ((wpc (exp theta))
|
||
|
|
(wc 1.0)
|
||
|
|
(ii 0 (+ ii 1)))
|
||
|
|
((= ii prev)
|
||
|
|
(set! prev mmax))
|
||
|
|
(do ((jj 0 (+ jj 1))
|
||
|
|
(i ii (+ i mmax))
|
||
|
|
(j (+ ii prev) (+ j mmax)))
|
||
|
|
((>= jj pow)
|
||
|
|
(set! wc (* wc wpc)))
|
||
|
|
(let ((tc (* wc (data j))))
|
||
|
|
(set! (data j) (- (data i) tc))
|
||
|
|
(set! (data i) (+ (data i) tc))))))
|
||
|
|
data)
|
||
|
|
|
||
|
|
> (cfft (list 0.0 1+i 0.0 0.0))
|
||
|
|
<em class="gray">(1+1i -1+1i -1-1i 1-1i)</em>
|
||
|
|
> (cfft (vector 0.0 1+i 0.0 0.0))
|
||
|
|
<em class="gray">#(1+1i -1+1i -1-1i 1-1i)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>And a generic function that copies one sequence's elements into another sequence:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (copy-into source dest) ; this is equivalent to (copy source dest)
|
||
|
|
(do ((i 0 (+ i 1)))
|
||
|
|
((= i (min (length source) (length dest)))
|
||
|
|
dest)
|
||
|
|
(set! (dest i) (source i))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>but that is already built-in as the two-argument version of the copy function.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>There is one place where list-set! and friends are not the same as set!: the former
|
||
|
|
evaluate their first argument, but set! does not (with a quibble; see below):
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((str "hi")) (string-set! (let () str) 1 #\a) str)
|
||
|
|
<em class="gray">"ha"</em>
|
||
|
|
> (let ((str "hi")) (set! (let () str) 1 #\a) str)
|
||
|
|
<em class="gray">;((let () str) 1 #\a): too many arguments to set!</em>
|
||
|
|
> (let ((str "hi")) (set! ((let () str) 1) #\a) str)
|
||
|
|
<em class="gray">"ha"</em>
|
||
|
|
> (let ((str "hi")) (set! (str 1) #\a) str)
|
||
|
|
<em class="gray">"ha"</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>set! looks at its first argument to decide what to set.
|
||
|
|
If it's a symbol, no problem. If it's a pair, set! looks at its car to see if it is
|
||
|
|
some object that has a setter. If the car is itself a list, set! evaluates the internal
|
||
|
|
expression, and tries again. So the second case above is the only one that won't work.
|
||
|
|
And of course:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((x (list 1 2)))
|
||
|
|
(set! ((((lambda () (list x))) 0) 0) 3)
|
||
|
|
x)
|
||
|
|
<em class="gray">(3 2)</em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>By my count, around 20 of the Scheme built-in functions are already
|
||
|
|
generic in the sense
|
||
|
|
that they accept arguments of many types (leaving aside the numeric and
|
||
|
|
type checking functions, take for example equal?, display,
|
||
|
|
member, assoc, apply, eval, quasiquote, and values). s7 extends that
|
||
|
|
list with map, for-each, reverse,
|
||
|
|
and length, and adds a few others such as copy, fill!, sort!,
|
||
|
|
object->string, object->let, and append.
|
||
|
|
newLisp takes a more radical approach than s7: it extends operators such
|
||
|
|
as '>'
|
||
|
|
to compare strings and lists, as well as numbers. In map and for-each,
|
||
|
|
however, you can mix the argument
|
||
|
|
types, so I'm not as attracted to making '>' generic; you can't, for
|
||
|
|
example, <code>(> "hi" 32.1)</code>,
|
||
|
|
or even <code>(> 1 0+i)</code>.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<p>The somewhat non-standard generic sequence functions in s7 are:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(<em class="def" id="sortb">sort!</em> sequence less?)
|
||
|
|
(<em class="def" id="reverseb">reverse!</em> sequence) and (reverse sequence)
|
||
|
|
(<em class="def" id="fillb">fill!</em> sequence value (start 0) end)
|
||
|
|
(<em class="def" id="s7copy">copy</em> obj) and (copy source destination (start 0) end)
|
||
|
|
(<em class="def" id="objecttostring">object->string</em> obj)
|
||
|
|
(object->let obj)
|
||
|
|
(length obj)
|
||
|
|
(append . sequences)
|
||
|
|
(map func . sequences) and (for-each func . sequences)
|
||
|
|
(<a href="#equivalentp">equivalent?</a> obj1 obj2)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p><b>copy</b> returns a (shallow) copy of its argument. If a destination is provided,
|
||
|
|
it need not match the source in size or type. The start and end indices refer to the source.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (copy '(1 2 3 4) (make-list 2))
|
||
|
|
<em class="gray">(1 2)</em>
|
||
|
|
> (copy #(1 2 3 4) (make-list 5) 1) ; start at 1 in the source
|
||
|
|
<em class="gray">(2 3 4 #f #f)</em>
|
||
|
|
> (copy "1234" (make-vector 2))
|
||
|
|
<em class="gray">#(#\1 #\2)</em>
|
||
|
|
> (define lst (list 1 2 3 4 5))
|
||
|
|
<em class="gray">(1 2 3 4 5)</em>
|
||
|
|
> (copy #(8 9) (cddr lst))
|
||
|
|
<em class="gray">(8 9 5)</em>
|
||
|
|
> lst
|
||
|
|
<em class="gray">(1 2 8 9 5)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p><b>reverse!</b> is an in-place version of reverse. That is,
|
||
|
|
it modifies the sequence passed to it in the process of reversing its contents.
|
||
|
|
If the sequence is a list, remember to use set!:
|
||
|
|
<code>(set! p (reverse! p))</code>. This is somewhat inconsistent with other cases,
|
||
|
|
but historically, lisp programmers have treated the in-place reverse as the fast
|
||
|
|
version, so s7 follows suit.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (define lst (list 1 2 3))
|
||
|
|
<em class="gray">(1 2 3)</em>
|
||
|
|
> (reverse! lst)
|
||
|
|
<em class="gray">(3 2 1)</em>
|
||
|
|
> lst
|
||
|
|
<em class="gray">(1)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Leaving aside the weird list case,
|
||
|
|
<b>append</b> returns a sequence of the same type as its first argument.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (append #(1 2) '(3 4))
|
||
|
|
<em class="gray">#(1 2 3 4)</em>
|
||
|
|
> (append (float-vector) '(1 2) (byte-vector 3 4))
|
||
|
|
<em class="gray">(float-vector 1.0 2.0 3.0 4.0)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b>sort!</b> sorts a sequence using the
|
||
|
|
function passed as its second argument:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (sort! (list 3 4 8 2 0 1 5 9 7 6) <)
|
||
|
|
<em class="gray">(0 1 2 3 4 5 6 7 8 9)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Underlying some of these functions are generic iterators, also built-into s7:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(<em class="def" id="makeiterator">make-iterator</em> sequence)
|
||
|
|
(<em class="def" id="iteratorp">iterator?</em> obj)
|
||
|
|
(<em class="def" id="iterate">iterate</em> iterator)
|
||
|
|
(<em class="def" id="iteratorsequence">iterator-sequence</em> iterator)
|
||
|
|
(<em class="def" id="iteratoratend">iterator-at-end?</em> iterator)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p><b>make-iterator</b> takes a sequence argument and returns an iterator object that traverses
|
||
|
|
that sequence as it is called. The iterator itself can be treated as a function of no arguments,
|
||
|
|
or (for code clarity) it can be the argument to <b>iterate</b>, which does the same thing.
|
||
|
|
That is <code>(iter)</code> is the same as <code>(iterate iter)</code>. The sequence that an iterator is traversing
|
||
|
|
is <b>iterator-sequence</b>.
|
||
|
|
</p>
|
||
|
|
<p>
|
||
|
|
If the sequence is a hash-table or let, the iterator normally returns a cons of the key and value.
|
||
|
|
There are many cases where this overhead is objectionable, so make-iterator takes a third optional
|
||
|
|
argument, the cons to use (changing its car and cdr directly on each call).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>When an iterator reaches the end of its sequence, it returns #<eof>. It used to
|
||
|
|
return nil; I can't decide whether this change is an improvement. If an iterator over a
|
||
|
|
list notices that its list is circular, it returns #<eof>. map and for-each use
|
||
|
|
iterators, so if you pass a circular list to either, it will stop eventually. (An
|
||
|
|
arcane consequence for method writers: specialize make-iterator, not map or for-each).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define (find-if f sequence)
|
||
|
|
(let ((iter (make-iterator sequence)))
|
||
|
|
(do ((x (iter) (iter)))
|
||
|
|
((or (eof-object? x) (f x))
|
||
|
|
(and (not (eof-object? x)) x)))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>But of course a sequence might contain #<eof>! So to be really safe, use iterator-at-end?
|
||
|
|
instead of eof-object?.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>The argument to make-iterator can also be a function or macro.
|
||
|
|
There should be a variable named '+iterator+ with a non-#f
|
||
|
|
value in the closure's environment:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (make-circular-iterator obj)
|
||
|
|
(let ((iter (make-iterator obj)))
|
||
|
|
(make-iterator
|
||
|
|
(let ((+iterator+ #t))
|
||
|
|
(lambda ()
|
||
|
|
(case (iter)
|
||
|
|
((#<eof>) ((set! iter (make-iterator obj))))
|
||
|
|
(else)))))))
|
||
|
|
</pre>
|
||
|
|
<p>The 'iterator? variable is similar to the '+documentation+ variable used by documentation.
|
||
|
|
It gives make-iterator some hope of catching inadvertent bogus function arguments that would
|
||
|
|
otherwise cause an infinite loop.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="multidimensionalvectors"><h4>multidimensional vectors</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<p>
|
||
|
|
s7 supports
|
||
|
|
vectors with any number of dimensions. It is here, in particular, that generalized
|
||
|
|
set! shines. make-vector's second argument can be a list of dimensions, rather than
|
||
|
|
an integer as in the one dimensional case:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(make-vector (list 2 3 4))
|
||
|
|
(make-vector '(2 3) 1.0)
|
||
|
|
(vector-dimensions (make-vector '(2 3 4))) -> (2 3 4)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The second example includes the optional initial element.
|
||
|
|
<code>(vect i ...)</code> or <code>(vector-ref vect i ...)</code> return the given
|
||
|
|
element, and <code>(set! (vect i ...) value)</code> and <code>(vector-set! vect i ... value)</code>
|
||
|
|
set it. vector-length (or just length) returns the total number of elements.
|
||
|
|
vector-dimensions returns a list of the dimensions; vector-rank returns the length of this list,
|
||
|
|
and vector-dimension returns the nth member of the list (the size of the nth dimension).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define v (make-vector '(2 3) 1.0))
|
||
|
|
<em class="gray">#2d((1.0 1.0 1.0) (1.0 1.0 1.0))</em>
|
||
|
|
> (set! (v 0 1) 2.0)
|
||
|
|
<em class="gray">#2d((1.0 2.0 1.0) (1.0 1.0 1.0))</em>
|
||
|
|
> (v 0 1)
|
||
|
|
<em class="gray">2.0</em>
|
||
|
|
> (vector-length v)
|
||
|
|
<em class="gray">6</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>This function initializes each element of a multidimensional vector:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define (make-array dims . inits)
|
||
|
|
(subvector (apply vector (flatten inits)) 0 (apply * dims) dims))
|
||
|
|
|
||
|
|
> (make-array '(3 3) '(1 1 1) '(2 2 2) '(3 3 3))
|
||
|
|
<em class="gray">#2d((1 1 1) (2 2 2) (3 3 3))</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>make-int-vector, make-float-vector, and make-byte-vector produce homogeneous vectors holding
|
||
|
|
s7_ints, s7_doubles, or unsigned bytes.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(<em class="def" id="makevector">make-vector</em> length-or-list-of-dimensions initial-value element-type-function)
|
||
|
|
(<em class="def" id="vectordimensions">vector-dimensions</em> vect)
|
||
|
|
(<em class="def" id="vectordimension">vector-dimension</em> vect n)
|
||
|
|
(<em class="def" id="vectorrank">vector-rank</em> obj)
|
||
|
|
|
||
|
|
(<em class="def">float-vector?</em> obj)
|
||
|
|
(<em class="def">float-vector</em> . args)
|
||
|
|
(<em class="def">make-float-vector</em> len (init 0.0))
|
||
|
|
(<em class="def">float-vector-ref</em> obj . indices)
|
||
|
|
(<em class="def">float-vector-set!</em> obj indices[...] value)
|
||
|
|
|
||
|
|
(<em class="def" id="intvectorp">int-vector?</em> obj)
|
||
|
|
(<em class="def" id="intvector">int-vector</em> . args)
|
||
|
|
(<em class="def" id="makeintvector">make-int-vector</em> len (init 0))
|
||
|
|
(<em class="def" id="intvectorref">int-vector-ref</em> obj . indices)
|
||
|
|
(<em class="def" id="intvectorset">int-vector-set!</em> obj indices[...] value)
|
||
|
|
|
||
|
|
(<em class="def" id="bytevectorp">byte-vector?</em> obj)
|
||
|
|
(<em class="def" id="bytevector">byte-vector</em> . args)
|
||
|
|
(<em class="def" id="makebytevector">make-byte-vector</em> len (init 0))
|
||
|
|
(<em class="def" id="bytevectorref">byte-vector-ref</em> obj . indices)
|
||
|
|
(<em class="def" id="bytevectorset">byte-vector-set!</em> obj indices[...] byte)
|
||
|
|
(<em class="def" id="bytep">byte?</em> obj)
|
||
|
|
|
||
|
|
(<em class="def" id="stringtobytevector">string->byte-vector</em> str)
|
||
|
|
(<em class="def" id="bytevectortostring">byte-vector->string</em> str)
|
||
|
|
|
||
|
|
(<em class="def" id="subvector">subvector</em> vector start end dimensions)
|
||
|
|
(<em class="def" id="subvectorp">subvector?</em> obj)
|
||
|
|
(<em class="def" id="subvectorvector">subvector-vector</em> obj)
|
||
|
|
(<em class="def" id="subvectorposition">subvector-position</em> obj)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p id="typedvectors">In addition to the dimension list mentioned above, make-vector accepts
|
||
|
|
optional arguments giving the initial element and the element type. If the
|
||
|
|
type is given, every attempt to set an element of the vector first calls
|
||
|
|
the type function on the new value.
|
||
|
|
If the type function is omitted (or set to #t),
|
||
|
|
no type checking is performed.
|
||
|
|
If the type function is a closure (rather than a C-defined or built-in function),
|
||
|
|
its name must be accessible; it can't be an anonymous lambda (the signature and
|
||
|
|
error handlers need this name).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define v (make-vector 3 'x symbol?)) ; initial element: 'x, elements must be symbols
|
||
|
|
<em class="gray">#(x x x)</em>
|
||
|
|
> (vector-set! v 0 123)
|
||
|
|
<em class="red">error</em><em class="gray">: vector-set! argument 3, 123, is an integer but should be a symbol?</em>
|
||
|
|
> (define (10|12? val) (memv val '(10 12)))
|
||
|
|
<em class="gray">10|12?</em>
|
||
|
|
> (define v1 (make-vector 3 10 10|12?)) ; only allow values 10 or 12 (initially 10)
|
||
|
|
<em class="gray">#(10 10 10)</em>
|
||
|
|
> (set! (v1 0) 12)
|
||
|
|
<em class="gray">12</em>
|
||
|
|
> v1
|
||
|
|
<em class="gray">#(12 10 10)</em>
|
||
|
|
> (set! (v1 1) 32)
|
||
|
|
<em class="red">error</em><em class="gray">: vector-set! argument 3, 32, is an integer but should be a 10|12?</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>To access a vector's elements with different dimensions than the original had, use
|
||
|
|
<code>(subvector original-vector 0 (length original-vector) new-dimensions)</code>:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((v1 #2d((1 2 3) (4 5 6))))
|
||
|
|
(let ((v2 (subvector v1))) ; flatten the original (1D is the default)
|
||
|
|
v2))
|
||
|
|
<em class="gray">#(1 2 3 4 5 6)</em>
|
||
|
|
> (let ((v1 #(1 2 3 4 5 6)))
|
||
|
|
(let ((v2 (subvector v1 0 6 '(3 2))))
|
||
|
|
v2))
|
||
|
|
<em class="gray">#2d((1 2) (3 4) (5 6))</em>
|
||
|
|
</pre>
|
||
|
|
<p>A subvector is a window onto some other vector's data. The data is not copied, just accessed differently.
|
||
|
|
The new-dimensions parameter is a list giving the lengths of the dimensions. The start and
|
||
|
|
end parameters refer to positions in the original vector.
|
||
|
|
subvector-vector returns
|
||
|
|
the underlying vector, and subvector-position returns the starting point of the subvector
|
||
|
|
in the underlying data.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="small">
|
||
|
|
<p>subvector's parameter list changed 8-Jul-2020. It was <code>(subvector vect new-length-or-dimension-list start)</code>,
|
||
|
|
but that conflicts with substring, and is confusing (the start position follows the length). To translate from
|
||
|
|
the old subvector to the new:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define* (old-subvector vect len (offset 0))
|
||
|
|
(if (pair? len)
|
||
|
|
(subvector vect offset (+ offset (apply * len)) len)
|
||
|
|
(if (not len)
|
||
|
|
(subvector vect offset (length vect))
|
||
|
|
(subvector vect offset (+ offset len)))))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
<blockquote>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>matrix multiplication:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre>(define (matrix-multiply A B)
|
||
|
|
;; assume square matrices and so on for simplicity
|
||
|
|
(let ((size (car (vector-dimensions A))))
|
||
|
|
(do ((C (make-vector (list size size) 0))
|
||
|
|
(i 0 (+ i 1)))
|
||
|
|
((= i size) C)
|
||
|
|
(do ((j 0 (+ j 1)))
|
||
|
|
((= j size))
|
||
|
|
(do ((sum 0)
|
||
|
|
(k 0 (+ k 1)))
|
||
|
|
((= k size)
|
||
|
|
(set! (C i j) sum))
|
||
|
|
(set! sum (+ sum (* (A i k) (B k j)))))))))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Conway's game of Life:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre>(define* (life (width 40) (height 40))
|
||
|
|
(let ((state0 (make-vector (list width height) 0))
|
||
|
|
(state1 (make-vector (list width height) 0)))
|
||
|
|
|
||
|
|
;; initialize with some random pattern
|
||
|
|
(do ((x 0 (+ x 1)))
|
||
|
|
((= x width))
|
||
|
|
(do ((y 0 (+ y 1)))
|
||
|
|
((= y height))
|
||
|
|
(set! (state0 x y) (if (< (random 100) 15) 1 0))))
|
||
|
|
|
||
|
|
(do () ()
|
||
|
|
;; show current state (using terminal escape sequences, borrowed from the Rosetta C code)
|
||
|
|
(format *stderr* "~C[H" #\escape) ; ESC H = tab set
|
||
|
|
(do ((y 0 (+ y 1)))
|
||
|
|
((= y height))
|
||
|
|
(do ((x 0 (+ x 1)))
|
||
|
|
((= x width))
|
||
|
|
(format *stderr*
|
||
|
|
(if (zero? (state0 x y))
|
||
|
|
" " ; ESC 07m below = inverse
|
||
|
|
(values "~C[07m ~C[m" #\escape #\escape))))
|
||
|
|
(format *stderr* "~C[E" #\escape)) ; ESC E = next line
|
||
|
|
|
||
|
|
;; get the next state
|
||
|
|
(do ((x 1 (+ x 1)))
|
||
|
|
((= x (- width 1)))
|
||
|
|
(do ((y 1 (+ y 1)))
|
||
|
|
((= y (- height 1)))
|
||
|
|
(let ((n (+ (state0 (- x 1) (- y 1))
|
||
|
|
(state0 x (- y 1))
|
||
|
|
(state0 (+ x 1) (- y 1))
|
||
|
|
(state0 (- x 1) y)
|
||
|
|
(state0 (+ x 1) y)
|
||
|
|
(state0 (- x 1) (+ y 1))
|
||
|
|
(state0 x (+ y 1))
|
||
|
|
(state0 (+ x 1) (+ y 1)))))
|
||
|
|
(set! (state1 x y)
|
||
|
|
(if (or (= n 3)
|
||
|
|
(and (= n 2)
|
||
|
|
(not (zero? (state0 x y)))))
|
||
|
|
1 0)))))
|
||
|
|
(copy state1 state0))))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Multidimensional vector constant syntax is modelled after CL: #nd(...)
|
||
|
|
signals that the lists specify the elements of an 'n' dimensional vector: <code>#2d((1 2 3) (4 5 6))</code>
|
||
|
|
int-vector constants use #i, float-vectors use #r. I wanted to use #f, but that is already taken.
|
||
|
|
Append the "nd" business after the type indication: <code>#i2d((1 2) (3 4))</code>. This syntax
|
||
|
|
collides with the r7rs byte-vector notation "#u8"; s7 uses "#u" for byte-vectors. "#u2d(...)" is a two-dimensional byte-vector.
|
||
|
|
For backwards compatibility, you can use "#u8" for one-dimensional byte-vectors.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (vector-ref #2d((1 2 3) (4 5 6)) 1 2)
|
||
|
|
<em class="gray">6</em>
|
||
|
|
> (matrix-multiply #2d((-1 0) (0 -1)) #2d((2 0) (-2 2)))
|
||
|
|
<em class="gray">#2d((-2 0) (2 -2))</em>
|
||
|
|
> (int-vector 1 2 3)
|
||
|
|
<em class="gray">#i(1 2 3)</em>
|
||
|
|
> (make-float-vector '(2 3) 1.0)
|
||
|
|
<em class="gray">#r2d((1.0 1.0 1.0) (1.0 1.0 1.0))</em>
|
||
|
|
> (vector (vector 1 2) (int-vector 1 2) (float-vector 1 2))
|
||
|
|
<em class="gray">#(#(1 2) #i(1 2) #r(1.0 2.0))</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>If any dimension has 0 length, you get an n-dimensional empty vector. It is not
|
||
|
|
equal to a 1-dimensional empty vector.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (make-vector '(10 0 3))
|
||
|
|
<em class="gray">#3d()</em>
|
||
|
|
> (equal? #() #3d())
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>To save on costly parentheses, and make it easier to write generic multidimensional sequence functions,
|
||
|
|
you can use this same syntax with lists.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((L '((1 2 3) (4 5 6))))
|
||
|
|
(L 1 0)) ; same as (list-ref (list-ref L 1) 0) or ((L 1) 0)
|
||
|
|
<em class="gray">4</em>
|
||
|
|
> (let ((L '(((1 2 3) (4 5 6)) ((7 8 9) (10 11 12)))))
|
||
|
|
(set! (L 1 0 2) 32) ; same as (list-set! (list-ref (list-ref L 1) 0) 2 32) which is unreadable!
|
||
|
|
L)
|
||
|
|
<em class="gray">(((1 2 3) (4 5 6)) ((7 8 32) (10 11 12)))</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Or with vectors of vectors, of course:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((V #(#(1 2 3) #(4 5 6))))
|
||
|
|
(V 1 2)) ; same as (vector-ref (vector-ref V 1) 2) or ((V 1) 2)
|
||
|
|
<em class="gray">6</em>
|
||
|
|
> (let ((V #2d((1 2 3) (4 5 6))))
|
||
|
|
(V 0))
|
||
|
|
<em class="gray">#(1 2 3)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>There's one difference between a vector-of-vectors and a multidimensional vector:
|
||
|
|
in the latter case, you can't clobber one of the inner vectors.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((V #(#(1 2 3) #(4 5 6)))) (set! (V 1) 32) V)
|
||
|
|
<em class="gray">#(#(1 2 3) 32)</em>
|
||
|
|
> (let ((V #2d((1 2 3) (4 5 6)))) (set! (V 1) 32) V)
|
||
|
|
<em class="gray">;not enough arguments for vector-set!: (#2d((1 2 3) (4 5 6)) 1 32)</em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Using lists to display the inner vectors may not be optimal, especially when the elements are also lists:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">#2d(((0) (0) ((0))) ((0) 0 ((0))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The "#()" notation is no better (the elements can be vectors), and I'm not a fan of "[]" parentheses.
|
||
|
|
Perhaps we could use different colors? Or different size parentheses?
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">#2D<em class="green">(</em><em class="red">(</em>(0) (0) ((0))<em class="red">)</em> <em class="red">(</em>(0) 0 ((0))<em class="red">)</em><em class="green">)</em>
|
||
|
|
#2D<em class="bigger">(</em><em class="big">(</em>(0) (0) ((0))<em class="big">)</em> <em class="big">(</em>(0) 0 ((0))<em class="big">)</em><em class="bigger">)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>I'm not sure how to handle vector->list and list->vector in the multidimensional case.
|
||
|
|
Currently, vector->list flattens the vector, and list->vector always returns a
|
||
|
|
one dimensional vector, so the two are not inverses.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (vector->list #2d((1 2) (3 4)))
|
||
|
|
<em class="gray">(1 2 3 4)</em> ; should this be '((1 2) (3 4)) or '(#(1 2) #(3 4))?
|
||
|
|
> (list->vector '(#(1 2) #(3 4))) ; what about '((1 2) (3 4))?
|
||
|
|
<em class="gray">#(#(1 2) #(3 4)) </em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
This also affects format and sort!:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (format #f "~{~A~^ ~}" #2d((1 2) (3 4)))
|
||
|
|
<em class="gray">"1 2 3 4"</em>
|
||
|
|
> (sort! #2d((1 4) (3 2)) >)
|
||
|
|
<em class="gray">#2d((4 3) (2 1))</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Perhaps subvector can help:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">>(subvector (list->vector '(1 2 3 4)) 0 4 '(2 2))
|
||
|
|
<em class="gray">#2d((1 2) (3 4))</em>
|
||
|
|
> (let ((a #2d((1 2) (3 4)))
|
||
|
|
(b #2d((5 6) (7 8))))
|
||
|
|
(list (subvector (append a b) 0 8 '(2 4))
|
||
|
|
(subvector (append a b) 0 8 '(4 2))
|
||
|
|
(subvector (append (a 0) (b 0) (a 1) (b 1)) 0 8 '(2 4))
|
||
|
|
(subvector (append (a 0) (b 0) (a 1) (b 1)) 0 8 '(4 2))))
|
||
|
|
<em class="gray">(#2d((1 2 3 4) (5 6 7 8))
|
||
|
|
#2d((1 2) (3 4) (5 6) (7 8))
|
||
|
|
#2d((1 2 5 6) (3 4 7 8))
|
||
|
|
#2d((1 2) (5 6) (3 4) (7 8)))</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Another question: should we accept the multi-index syntax in a case such as <code>
|
||
|
|
(#("abc" "def") 0 2)</code>?
|
||
|
|
My first thought was that the indices should all refer to the same
|
||
|
|
type of object, so s7 would complain in a mixed case like that.
|
||
|
|
If we can nest any applicable objects and apply the whole thing to
|
||
|
|
an arbitrary list of indices, ambiguities arise:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">((lambda (x) x) "hi" 0)
|
||
|
|
((lambda (x) (lambda (y) (+ x y))) 1 2)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>I think these should complain that the function got too many arguments,
|
||
|
|
but from the implicit indexing point of view, they could be interpreted
|
||
|
|
as:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(string-ref ((lambda (x) x) "hi") 0) ; i.e. (((lambda (x) x) "hi") 0)
|
||
|
|
(((lambda (x) (lambda (y) (+ x y))) 1) 2)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Add optional and rest arguments, and you can't tell who is supposed to
|
||
|
|
take which arguments.
|
||
|
|
Currently, you can mix types with implicit indices,
|
||
|
|
but a function grabs all remaining indices.
|
||
|
|
To insist that all objects are of the same type, use an explicit getter:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (list-ref (list 1 (list 2 3)) 1 0) ; same as ((list 1 (list 2 3)) 1 0)
|
||
|
|
<em class="gray">2</em>
|
||
|
|
> ((list 1 (vector 2 3)) 1 0)
|
||
|
|
<em class="gray">2</em>
|
||
|
|
> (list-ref (list 1 (vector 2 3)) 1 0)
|
||
|
|
<em class="red">error</em><em class="gray">: list-ref argument 1, #(2 3), is a vector but should be a proper list</em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="hashtables"><h4>hash-tables</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<ul>
|
||
|
|
<li>(<em class="def" id="makehashtable">make-hash-table</em> (size 8) eq-func typers)
|
||
|
|
</li><li>(<em class="def" id="makeweakhashtable">make-weak-hash-table</em> (size 8) eq-func typers)
|
||
|
|
</li><li>(<em class="def" id="hashtable">hash-table</em> ...)
|
||
|
|
</li><li>(<em class="def" id="weakhashtable">weak-hash-table</em> ...)
|
||
|
|
</li><li>(<em class="def" id="hashtablep">hash-table?</em> obj)
|
||
|
|
</li><li>(<em class="def" id="weakhashtablep">weak-hash-table?</em> obj)
|
||
|
|
</li><li>(<em class="def" id="hashtableref">hash-table-ref</em> ht key)
|
||
|
|
</li><li>(<em class="def" id="hashtableset">hash-table-set!</em> ht key value)
|
||
|
|
</li><li>(<em class="def" id="hashtableentries">hash-table-entries</em> ht)
|
||
|
|
</li><li>(<em class="def" id="hashcode">hash-code</em> obj eqfunc)
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
Each hash-table keeps track of the keys it contains, optimizing the search wherever possible.
|
||
|
|
Any s7 object can be the key or the key's value.
|
||
|
|
If you pass a table size that is not a power of 2, make-hash-table rounds it up to the next power of 2.
|
||
|
|
The table grows as needed. length returns the current size.
|
||
|
|
If a key is not in the table, hash-table-ref returns #f. To remove a key,
|
||
|
|
set its value to #f; to remove all keys, <code>(fill! table #f)</code>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((ht (make-hash-table)))
|
||
|
|
(set! (ht "hi") 123)
|
||
|
|
(ht "hi"))
|
||
|
|
<em class="gray">123</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>hash-table (the function) parallels the functions vector, list, and string.
|
||
|
|
Its arguments are
|
||
|
|
the keys and values: <code>(hash-table 'a 1 'b 2)</code>.
|
||
|
|
Implicit indexing gives multilevel hashes:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((h (hash-table 'a (hash-table 'b 2 'c 3)))) (h 'a 'b))
|
||
|
|
<em class="gray">2</em>
|
||
|
|
> (let ((h (hash-table 'a (hash-table 'b 2 'c 3)))) (set! (h 'a 'b) 4) (h 'a 'b))
|
||
|
|
<em class="gray">4</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>hash-code is like Common Lisp's sxhash. It returns an integer that can be associated with
|
||
|
|
an s7 object when implementing your own hash-tables. s7test.scm has an example using vectors.
|
||
|
|
The eqfunc argument is currently ignored (hash-code assumes equal? is in use).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Since hash-tables accept the same applicable-object syntax that vectors use, we can
|
||
|
|
treat a hash-table as, for example, a sparse array:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define make-sparse-array make-hash-table)
|
||
|
|
<em class="gray">make-sparse-array</em>
|
||
|
|
> (let ((arr (make-sparse-array)))
|
||
|
|
(set! (arr 1032) "1032")
|
||
|
|
(set! (arr -23) "-23")
|
||
|
|
(list (arr 1032) (arr -23)))
|
||
|
|
<em class="gray">("1032" "-23")</em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>map and for-each accept hash-table arguments. On each iteration, the map or for-each function is passed
|
||
|
|
an entry, <code>'(key . value)</code>, in whatever order the entries are encountered in the table.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define (hash-table->alist table)
|
||
|
|
(map values table))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>reverse of a hash-table returns a new table with the keys and values reversed.
|
||
|
|
fill! sets all the values.
|
||
|
|
Two hash-tables are equal if they have the same keys with the same values. This is independent
|
||
|
|
of the table sizes, or the order in which the key/value pairs were added.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>The second argument to make-hash-table (eq-func) is slightly complicated. If it is omitted,
|
||
|
|
s7 chooses the hashing equality and mapping functions based on the keys in the hash-table.
|
||
|
|
There are times when you know
|
||
|
|
in advance what equality function you want. If it's one of the built-in s7 equality
|
||
|
|
functions, eq?, eqv?, equal?, equivalent?, =, string=?, string-ci=?, char=?, or char-ci=?,
|
||
|
|
you can pass that function as the second argument. In any other case, you need to
|
||
|
|
give s7 both the equality function and the mapping function. The latter takes any object
|
||
|
|
and returns the hash-table location for it (an integer). The problem here is that
|
||
|
|
for the arbitrary equality function to work, objects that are equal according to that
|
||
|
|
function have to be mapped to the same hash-table location. There's no way for s7 to intuit
|
||
|
|
what this mapping should be except in the built-in cases. So to specify some arbitrary function, the second
|
||
|
|
argument is a cons: '(equality-checker mapper).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Here's a brief example. In CLM, we have c-objects of type mus-generator (from s7's point of view),
|
||
|
|
and we want to hash them using equal? (which will call the generator-specific equality function).
|
||
|
|
But s7 doesn't realize that the mus-generator type covers 40 or 50 internal types, so as the mapper we pass mus-type:
|
||
|
|
<code>(make-hash-table 64 (cons equal? mus-type))</code>.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>If the hash key is a float (a non-rational number), hash-table-ref uses <a href="#equivalentp">equivalent?</a>.
|
||
|
|
Otherwise, for example, you could use NaN as a key, but then never be able to access it!
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>To implement read-time hash-tables using #h(...):
|
||
|
|
</p>
|
||
|
|
<pre>(set! *#readers*
|
||
|
|
(cons (cons #\h (lambda (str)
|
||
|
|
(and (string=? str "h") ; #h(...)
|
||
|
|
(apply hash-table (read)))))
|
||
|
|
*#readers*))
|
||
|
|
|
||
|
|
(display #h(:a 1)) (newline)
|
||
|
|
(display #h(:a 1 :b "str")) (newline)
|
||
|
|
</pre>
|
||
|
|
<p>These can be made immutable by <code>(immutable! (apply...))</code>, or even better,
|
||
|
|
</p>
|
||
|
|
<pre>(let ((h (apply hash-table (read))))
|
||
|
|
(if (> (*s7* 'safety) 1) (immutable! h) h))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>(define-macro (define-memoized name&arg . body)
|
||
|
|
(let ((arg (cadr name&arg))
|
||
|
|
(memo (gensym "memo")))
|
||
|
|
`(define ,(car name&arg)
|
||
|
|
(let ((,memo (<em class="red">make-hash-table</em>)))
|
||
|
|
(lambda (,arg)
|
||
|
|
(or (,memo ,arg) ; check for saved value
|
||
|
|
(set! (,memo ,arg) (begin ,@body)))))))) ; set! returns the new value
|
||
|
|
|
||
|
|
> (define (fib n)
|
||
|
|
(if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
|
||
|
|
<em class="gray">fib</em>
|
||
|
|
> (define-memoized
|
||
|
|
(memo-fib n)
|
||
|
|
(if (< n 2) n (+ (memo-fib (- n 1)) (memo-fib (- n 2)))))
|
||
|
|
<em class="gray">memo-fib</em>
|
||
|
|
> (time (fib 34)) ; un-memoized time
|
||
|
|
<em class="gray">1.168</em> ; 0.70 on ccrma's i7-3930 machines
|
||
|
|
> (time (memo-fib 34)) ; memoized time
|
||
|
|
<em class="gray">3.200e-05</em>
|
||
|
|
> (outlet (funclet memo-fib))
|
||
|
|
<em class="gray">(inlet '{memo}-18 (hash-table
|
||
|
|
'(0 . 0) '(1 . 1) '(2 . 1) '(3 . 2) '(4 . 3) '(5 . 5)
|
||
|
|
'(6 . 8) '(7 . 13) '(8 . 21) '(9 . 34) '(10 . 55) '(11 . 89)
|
||
|
|
'(12 . 144) '(13 . 233) '(14 . 377) '(15 . 610) '(16 . 987)
|
||
|
|
'(17 . 1597) '(18 . 2584) '(19 . 4181) '(20 . 6765) '(21 . 10946)
|
||
|
|
'(22 . 17711) '(23 . 28657) '(24 . 46368) '(25 . 75025) '(26 . 121393)
|
||
|
|
'(27 . 196418) '(28 . 317811) '(29 . 514229) '(30 . 832040) '(31 . 1346269)
|
||
|
|
'(32 . 2178309) '(33 . 3524578) '(34 . 5702887)))</em>
|
||
|
|
</pre>
|
||
|
|
<p>but the tail recursive version of fib is simpler and almost as fast as the memoized version,
|
||
|
|
and the iterative version beats both.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<p id="typedhash">The third argument, typers, sets type checkers for the keys and values in the table,
|
||
|
|
much like the third argument to make-vector.
|
||
|
|
It is a cons of the type functions,
|
||
|
|
<code>(cons symbol? integer?)</code> for example. This says that all the keys must
|
||
|
|
be symbols and all the values integers.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (define (10|12? val) (memv val '(10 12)))
|
||
|
|
<em class="gray">10|12?</em>
|
||
|
|
> (define hash (make-hash-table 8 #f (cons #t 10|12?))) ; any key is ok, but all values must be 10 or 12
|
||
|
|
<em class="gray">(hash-table)</em>
|
||
|
|
> (set! (hash 'a) 10)
|
||
|
|
<em class="gray">10</em>
|
||
|
|
> hash
|
||
|
|
<em class="gray">(hash-table 'a 10)</em>
|
||
|
|
> (set! (hash 'b) 32)
|
||
|
|
<em class="red">error</em><em class="gray">: hash-table-set! value argument 3, 32, is an integer but should be a 10|12?</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="environments"><h4>environments</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<p>An environment holds symbols and their values. The global environment, for example,
|
||
|
|
holds all the variables that are defined at the top level.
|
||
|
|
Environments are first class (and applicable) objects in s7.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(<em class="def" id="rootlet">rootlet</em>) the top-level (global) environment
|
||
|
|
(<em class="def" id="curlet">curlet</em>) the current (innermost) environment
|
||
|
|
(<em class="def" id="funclet">funclet</em> proc) the environment at the time when proc was defined
|
||
|
|
(<em class="def" id="isfunclet">funclet?</em> env) #t if env is a funclet
|
||
|
|
(owlet) the environment at the point of the last error
|
||
|
|
(<em class="def" id="unlet">unlet</em>) a let with any built-in functions that do not have their original value
|
||
|
|
|
||
|
|
(<em class="def" id="letref">let-ref</em> env sym) get value of sym in env, same as (env sym)
|
||
|
|
(<em class="def" id="letset">let-set!</em> env sym val) set value of sym in env to val, same as (set! (env sym) val)
|
||
|
|
|
||
|
|
(<em class="def" id="inlet">inlet</em> . bindings) make a new environment with the given bindings
|
||
|
|
(<em class="def" id="sublet">sublet</em> env . bindings) same as inlet, but the new environment is local to env
|
||
|
|
(<em class="def" id="varlet">varlet</em> env . bindings) add new bindings directly to env
|
||
|
|
(<em class="def" id="cutlet">cutlet</em> env . fields) remove bindings from env
|
||
|
|
|
||
|
|
(<em class="def" id="letp">let?</em> obj) #t if obj is an environment
|
||
|
|
(<em class="def" id="with-let">with-let</em> env . body) evaluate body in the environment env
|
||
|
|
(<em class="def" id="outlet">outlet</em> env) the environment that encloses the environment env (settable)
|
||
|
|
(<em class="def" id="lettolist">let->list</em> env) return the environment bindings as a list of (symbol . value) cons's
|
||
|
|
|
||
|
|
(<em class="def" id="openlet">openlet</em> env) mark env as open (see below)
|
||
|
|
(<em class="def" id="openletp">openlet?</em> env) #t is env is open
|
||
|
|
(<em class="def" id="coverlet">coverlet</em> env) mark env as closed (undo an earlier openlet)
|
||
|
|
|
||
|
|
(<em class="def" id="objecttolet">object->let</em> obj) return an environment containing information about obj
|
||
|
|
(<em class="def" id="lettemporarily">let-temporarily</em> vars . body)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<pre class="indented">> (inlet 'a 1 'b 2)
|
||
|
|
<em class="gray">(inlet 'a 1 'b 2)</em>
|
||
|
|
> (let ((a 1) (b 2)) (curlet))
|
||
|
|
<em class="gray">(inlet 'a 1 'b 2)</em>
|
||
|
|
> (let ((x (inlet :a 1 :b 2))) (x 'a))
|
||
|
|
<em class="gray">1</em>
|
||
|
|
> (with-let (inlet 'a 1 'b 2) (+ a b))
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (let ((x (inlet :a 1 :b 2))) (set! (x 'a) 4) x)
|
||
|
|
<em class="gray">(inlet 'a 4 'b 2)</em>
|
||
|
|
> (let ((x (inlet))) (varlet x 'a 1) x)
|
||
|
|
<em class="gray">(inlet 'a 1)</em>
|
||
|
|
> (let ((a 1)) (let ((b 2)) (outlet (curlet))))
|
||
|
|
<em class="gray">(inlet 'a 1)</em>
|
||
|
|
> (let ((e (inlet 'a (inlet 'b 1 'c 2)))) (e 'a 'b)) ; in C terms, e->a->b
|
||
|
|
<em class="gray">1</em>
|
||
|
|
> (let ((e (inlet 'a (inlet 'b 1 'c 2)))) (set! (e 'a 'b) 3) (e 'a 'b))
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (define* (make-let (a 1) (b 2)) (sublet (rootlet) (curlet)))
|
||
|
|
<em class="gray">make-let</em>
|
||
|
|
> (make-let :b 32)
|
||
|
|
<em class="gray">(inlet 'a 1 'b 32)</em>
|
||
|
|
</pre>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
<p>As the names suggest, in s7 an environment is viewed as a disembodied let. Environments are equal if they
|
||
|
|
contain the same symbols with the same values leaving aside shadowing, and taking into account the environment
|
||
|
|
chain up to the rootlet. That is, two environments are equal if any local variable of either has the same value in both.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p><b>let-ref</b> and <b>let-set!</b> return #<undefined> if the first argument is not
|
||
|
|
defined in the environment or its parents. To search just the given environment (ignoring its outlet chain),
|
||
|
|
use defined? with the third argument #t before calling let-ref or let-set!:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (defined? 'car (inlet 'a 1) #t)
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
> (defined? 'car (inlet 'a 1))
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>This matters in let-set!: <code>(let-set! (inlet 'a 1) 'car #f)</code>
|
||
|
|
is the same as <code>(set! car #f)</code>!
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b>with-let</b> evaluates its body in the given environment, so
|
||
|
|
<code>(with-let e . body)</code> is equivalent to
|
||
|
|
<code>(eval `(begin ,@body) e)</code>, but probably faster.
|
||
|
|
Similarly, <code>(let bindings . body)</code> is equivalent to
|
||
|
|
<code>(eval `(begin ,@body) (apply inlet (flatten bindings)))</code>,
|
||
|
|
ignoring the outer (enclosing) environment (the default outer environment
|
||
|
|
of inlet is rootlet).
|
||
|
|
Or better,
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define-macro (with-environs e . body)
|
||
|
|
`(apply let (map (lambda (a) (list (car a) (cdr a))) ,e) '(,@body)))
|
||
|
|
</pre>
|
||
|
|
<p>Or turning it around,</p>
|
||
|
|
<pre>(define-macro (Let vars . body)
|
||
|
|
`(with-let (sublet (curlet)
|
||
|
|
,@(map (lambda (var)
|
||
|
|
(values (symbol->keyword (car var)) (cadr var)))
|
||
|
|
vars))
|
||
|
|
,@body))
|
||
|
|
|
||
|
|
(Let ((c 4))
|
||
|
|
(Let ((a 2)
|
||
|
|
(b (+ c 2)))
|
||
|
|
(+ a b c)))
|
||
|
|
</pre>
|
||
|
|
<p>It is faster to use <code>(biglet 'a-function)</code> than <code>(with-let biglet a-function)</code>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p><b>let-temporarily</b> (now built-into s7) is somewhat similar to fluid-let in other Schemes.
|
||
|
|
Its syntax looks like
|
||
|
|
let, but it first saves the current value, then sets the
|
||
|
|
variable to the new value (via set!), calls the body, and finally restores the
|
||
|
|
original value. It can handle anything settable:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(let-temporarily (((*s7* 'print-length) 8)) (display x))
|
||
|
|
</pre>
|
||
|
|
<p>This sets s7's print-length variable to 8 while displaying x, then
|
||
|
|
puts it back to its original value.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (define ourlet
|
||
|
|
(let ((x 1))
|
||
|
|
(define (a-func) x)
|
||
|
|
(define b-func (let ((y 1))
|
||
|
|
(lambda ()
|
||
|
|
(+ x y))))
|
||
|
|
(curlet)))
|
||
|
|
<em class="gray">(inlet 'x 1 'a-func a-func 'b-func b-func)</em>
|
||
|
|
> (ourlet 'x)
|
||
|
|
<em class="gray">1</em>
|
||
|
|
> (let-temporarily (((ourlet 'x) 2))
|
||
|
|
((ourlet 'a-func)))
|
||
|
|
<em class="gray">2</em>
|
||
|
|
> ((funclet (ourlet 'b-func)) 'y)
|
||
|
|
<em class="gray">1</em>
|
||
|
|
> (let-temporarily ((((funclet (ourlet 'b-func)) 'y) 3))
|
||
|
|
((ourlet 'b-func)))
|
||
|
|
<em class="gray">4</em>
|
||
|
|
</pre>
|
||
|
|
<p>Despite the name, no new environment is created by let-temporarily:
|
||
|
|
<code>(let () (let-temporarily () (define x 2)) (+ x 1))</code> is 3.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b>sublet</b> adds bindings (symbols with associated values) to an environment.
|
||
|
|
It does not change the environment passed to it, but
|
||
|
|
just prepends the new bindings, shadowing any old ones,
|
||
|
|
as if you had called "let".
|
||
|
|
To add the bindings directly to the environment,
|
||
|
|
use <b>varlet</b>. Both of these functions accept nil as the
|
||
|
|
'env' argument as shorthand for <code>(rootlet)</code>.
|
||
|
|
Both also accept other environments as well as individual bindings,
|
||
|
|
adding all the argument's bindings to the new environment.
|
||
|
|
<b>inlet</b> is very similar, but normally omits the environment argument.
|
||
|
|
The arguments to sublet and inlet can be passed as
|
||
|
|
symbol/value pairs, as a cons, or using keywords as if in define*.
|
||
|
|
inlet can also be used to copy an environment without accidentally invoking
|
||
|
|
that environment's copy method.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Here's an example: we want to define two functions that share a
|
||
|
|
local variable:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(varlet (curlet) ; import f1 and f2 into the current environment
|
||
|
|
(let ((x 1)) ; x is our local variable
|
||
|
|
(define (f1 a) (+ a x))
|
||
|
|
(define (f2 b) (* b x))
|
||
|
|
(inlet 'f1 f1 'f2 f2))) ; export f1 and f2
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>One way to add reader and writer functions to an individual environment slot is:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define e (inlet
|
||
|
|
'x (let ((local-x 3)) ; x's initial value
|
||
|
|
(dilambda
|
||
|
|
(lambda () local-x)
|
||
|
|
(lambda (val) (set! local-x (max 0 (min val 100))))))))
|
||
|
|
> ((e 'x))
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (set! ((e 'x)) 123)
|
||
|
|
<em class="gray">100</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p><b>funclet</b> returns a function's local environment. Here's an example that
|
||
|
|
keeps a circular buffer of the calls to that function:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define func (let ((history (let ((lst (make-list 8 #f)))
|
||
|
|
(set-cdr! (list-tail lst 7) lst))))
|
||
|
|
(lambda (x y)
|
||
|
|
(let ((result (+ x y)))
|
||
|
|
(set-car! history (list result x y))
|
||
|
|
(set! history (cdr history))
|
||
|
|
result))))
|
||
|
|
|
||
|
|
> (func 1 2)
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (func 3 4)
|
||
|
|
<em class="gray">7</em>
|
||
|
|
> ((funclet func) 'history)
|
||
|
|
<em class="gray">#1=(#f #f #f #f #f #f (3 1 2) (7 3 4) . #1#)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<p>It is possible in Scheme to redefine built-in functions such as car.
|
||
|
|
To ensure that some code sees the original built-in function definitions,
|
||
|
|
wrap it in <code>(with-let (unlet) ...)</code>:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (let ((caar 123))
|
||
|
|
(+ caar (with-let (unlet)
|
||
|
|
(caar '((2) 3)))))
|
||
|
|
<em class="gray">125</em>
|
||
|
|
</pre>
|
||
|
|
<p>Or perhaps better, to keep the current environment intact except for the
|
||
|
|
changed built-ins:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (let ((x 1)
|
||
|
|
(display 3))
|
||
|
|
(with-let (sublet (curlet) (unlet)) ; (curlet) picks up 'x, (unlet) the original 'display
|
||
|
|
(display x)))
|
||
|
|
<em class="gray">1</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<p>
|
||
|
|
with-let and unlet are constants, so you can
|
||
|
|
use them in any context without worrying about whether they've been redefined.
|
||
|
|
As mentioned in the macro section, #_<name> is a built-in reader macro
|
||
|
|
for <code>(with-let (unlet) <name>)</code>,
|
||
|
|
so for example, #_+ is the built-in + function, no matter what.
|
||
|
|
(The environment of built-in functions
|
||
|
|
that unlet accesses is not accessible from scheme code, so there's no way
|
||
|
|
that those values can be clobbered).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>
|
||
|
|
I think these functions can implement the notions of libraries,
|
||
|
|
separate namespaces, or modules.
|
||
|
|
Here's one way: first the library writer just writes his library.
|
||
|
|
The normal user simply loads it. The abnormal user worries about everything,
|
||
|
|
so first he loads the library in a local let to make sure no bindings escape
|
||
|
|
to pollute his code, and then he
|
||
|
|
uses unlet to
|
||
|
|
make sure that none of his bindings pollute the library code:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(let ()
|
||
|
|
(with-let (unlet)
|
||
|
|
(load "any-library.scm" (curlet))
|
||
|
|
;; by default load puts stuff in the global environment
|
||
|
|
...))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Now Abnormal User can do what he wants with the library entities.
|
||
|
|
Say he wants to use "lognor" under the name "bitwise-not-or", and
|
||
|
|
all the other functions are of no interest:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(varlet (curlet)
|
||
|
|
'bitwise-not-or (with-let (unlet)
|
||
|
|
(load "any-library.scm" (curlet))
|
||
|
|
lognor)) ; lognor is presumably defined in "any-library.scm"
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Say he wants to make sure the library is cleanly loaded, but all
|
||
|
|
its top-level bindings are imported into the current environment:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(varlet (curlet)
|
||
|
|
(with-let (unlet)
|
||
|
|
(let ()
|
||
|
|
(load "any-library.scm" (curlet))
|
||
|
|
(curlet)))) ; these are the bindings introduced by loading the library
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>To do the same thing, but prepend "library:" to each name:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(apply varlet (curlet)
|
||
|
|
(with-let (unlet)
|
||
|
|
(let ()
|
||
|
|
(load "any-library.scm" (curlet))
|
||
|
|
(map (lambda (binding)
|
||
|
|
(cons (symbol "library:" (symbol->string (car binding)))
|
||
|
|
(cdr binding)))
|
||
|
|
(curlet)))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>That's all there is to it! Here is the same idea as a macro:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre>(define-macro (let! init end . body)
|
||
|
|
;; syntax mimics 'do: (let! (vars&values) ((exported-names) result) body)
|
||
|
|
;; (let! ((a 1)) ((hiho)) (define (hiho x) (+ a x)))
|
||
|
|
`(let ,init
|
||
|
|
,@body
|
||
|
|
(varlet (outlet (curlet))
|
||
|
|
,@(map (lambda (export)
|
||
|
|
`(cons ',export ,export))
|
||
|
|
(car end)))
|
||
|
|
,@(cdr end)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<!--
|
||
|
|
(define-macro (safe-let! init end . body)
|
||
|
|
`(with-let (#_inlet (unlet)
|
||
|
|
,@(#_map (#_lambda (b)
|
||
|
|
`(#_cons ',(#_car b) ,(#_cadr b)))
|
||
|
|
init))
|
||
|
|
,@body
|
||
|
|
(#_varlet (#_outlet (#_curlet))
|
||
|
|
,@(#_map (#_lambda (export)
|
||
|
|
`(#_cons ',export ,export))
|
||
|
|
(#_car end)))
|
||
|
|
,@(#_cdr end)))
|
||
|
|
-->
|
||
|
|
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>Well, almost, darn it. If the loaded library file sets (via set!) a global value
|
||
|
|
such as abs, we need to put it back to its original form:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre>(define (safe-load file)
|
||
|
|
(let ((e (with-let (unlet) ; save the environment before loading
|
||
|
|
(let->list (curlet)))))
|
||
|
|
(<em class="red">load</em> file (curlet))
|
||
|
|
(let ((new-e (with-let (unlet) ; get the environment after loading
|
||
|
|
(let->list (curlet)))))
|
||
|
|
(for-each ; see if any built-in functions were stepped on
|
||
|
|
(lambda (sym)
|
||
|
|
(unless (assoc (car sym) e)
|
||
|
|
(format () "~S clobbered ~A~%" file (car sym))
|
||
|
|
(apply set! (car sym) (list (cdr sym)))))
|
||
|
|
new-e))))
|
||
|
|
|
||
|
|
;; say libtest.scm has the line (set! abs odd?)
|
||
|
|
|
||
|
|
> (safe-load "libtest.scm")
|
||
|
|
<em class="gray">"libtest.scm" clobbered abs</em>
|
||
|
|
> (abs -2)
|
||
|
|
<em class="gray">2</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
<p><b>openlet</b> marks its argument, either an environment, a closure, a c-object, or a c-pointer
|
||
|
|
as open; <b>coverlet</b> as closed. I need better terminology here! An open object is one that the
|
||
|
|
built-in s7 functions handle specially. If they encounter one in their
|
||
|
|
argument list, they look in the object for their own name, and call that
|
||
|
|
function if it exists. A bare-bones example:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (abs (openlet (inlet 'abs (lambda (x) 47))))
|
||
|
|
<em class="gray">47</em>
|
||
|
|
> (define* (f1 (a 1)) (if (real? a) (abs a) ((a 'f1) a)))
|
||
|
|
<em class="gray">f1</em>
|
||
|
|
> (f1 :a (openlet (inlet 'f1 (lambda (e) 47))))
|
||
|
|
<em class="gray">47</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>In CLOS, we'd declare a class and a method, and call make-instance,
|
||
|
|
and then discover that it wouldn't work anyway.
|
||
|
|
Here we have, in effect, an anonymous instance of an anonymous class.
|
||
|
|
I think this is called a "prototype system"; javascript is apparently similar.
|
||
|
|
A slightly more complex example:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(let* ((e1 (openlet
|
||
|
|
(inlet
|
||
|
|
'x 3
|
||
|
|
'* (lambda args
|
||
|
|
(apply * (if (number? (car args))
|
||
|
|
(values (car args) ((cadr args) 'x) (cddr args))
|
||
|
|
(values ((car args) 'x) (cdr args))))))))
|
||
|
|
(e2 (copy e1)))
|
||
|
|
(set! (e2 'x) 4)
|
||
|
|
(* 2 e1 e2)) ; (* 2 3 4) => 24
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Perhaps these names would be better: openlet -> with-methods, coverlet -> without-methods,
|
||
|
|
and openlet? -> methods?.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>let-ref and let-set! are problematic as methods. It is very easy to get into an infinite
|
||
|
|
loop, especially with let-ref since any reference to the let within the method body probably
|
||
|
|
calls let-ref, which calls the let-ref method. We used to recommend coverlet here, but
|
||
|
|
even that is not enough, so not let-ref and let-set! are immutable; they can't be used
|
||
|
|
as methods.
|
||
|
|
Use let-ref-fallback and let-set-fallback instead, if possible.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
<p><b>object->let</b> returns an environment (more of a dictionary really) that
|
||
|
|
contains details about its argument. It
|
||
|
|
is intended as a debugging aid, underlying a debugger's "inspect" for example.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((iter (make-iterator "1234")))
|
||
|
|
(iter)
|
||
|
|
(iter)
|
||
|
|
(object->let iter))
|
||
|
|
<em class="gray">(inlet 'value #<iterator: string> 'type iterator? 'at-end #f 'sequence "1234" 'length 4 'position 2)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>A c-object (in the sense of s7_make_c_type), can add its own info to this namespace via an object->let
|
||
|
|
method in its local environment. snd-marks.c has a simple example using a class-wide environment (g_mark_methods),
|
||
|
|
holding as the value of its 'object->let field the function s7_mark_to_let. The latter uses s7_varlet to
|
||
|
|
add information to the namespace created by <code>(object->let mark)</code>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>(define-macro (value->symbol expr)
|
||
|
|
`(let ((val ,expr)
|
||
|
|
(e1 (curlet)))
|
||
|
|
(call-with-exit
|
||
|
|
(lambda (return)
|
||
|
|
(do ((e e1 (outlet e))) ()
|
||
|
|
(for-each
|
||
|
|
(lambda (slot)
|
||
|
|
(if (equal? val (cdr slot))
|
||
|
|
(return (car slot))))
|
||
|
|
e)
|
||
|
|
(if (eq? e (rootlet))
|
||
|
|
(return #f)))))))
|
||
|
|
|
||
|
|
> (let ((a 1) (b "hi"))
|
||
|
|
(value->symbol "hi"))
|
||
|
|
<em class="gray">b</em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>openlet alerts the rest of s7 that the environment has methods.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre>(begin
|
||
|
|
(define fvector? #f)
|
||
|
|
(define make-fvector #f)
|
||
|
|
(let ((type (gensym))
|
||
|
|
(->float (lambda (x)
|
||
|
|
(if (real? x)
|
||
|
|
(* x 1.0)
|
||
|
|
(error 'wrong-type-arg "fvector new value is not a real: ~A" x)))))
|
||
|
|
(set! make-fvector
|
||
|
|
(lambda* (len (init 0.0))
|
||
|
|
(<em class="red">openlet</em>
|
||
|
|
(inlet :v (make-vector len (->float init))
|
||
|
|
:type type
|
||
|
|
:length (lambda (f) len)
|
||
|
|
:object->string (lambda (f . args) "#<fvector>")
|
||
|
|
:let-set! (lambda (fv i val) (#_vector-set! (fv 'v) i (->float val)))
|
||
|
|
:let-ref-fallback (lambda (fv i) (#_vector-ref (fv 'v) i))))))
|
||
|
|
(set! fvector? (lambda (p)
|
||
|
|
(and (let? p)
|
||
|
|
(eq? (p 'type) type))))))
|
||
|
|
|
||
|
|
> (define fv (make-fvector 32))
|
||
|
|
<em class="gray">fv</em>
|
||
|
|
> fv
|
||
|
|
<em class="gray">#<fvector></em>
|
||
|
|
> (length fv)
|
||
|
|
<em class="gray">32</em>
|
||
|
|
> (set! (fv 0) 123)
|
||
|
|
<em class="gray">123.0</em>
|
||
|
|
> (fv 0)
|
||
|
|
<em class="gray">123.0</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>If an s7 function ignores the type of an argument, as in cons or vector for example,
|
||
|
|
then that argument won't be treated as having any methods.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
Since outlet is settable, there are two ways an environment can
|
||
|
|
become circular. One is to include the current environment as the value of one of its variables.
|
||
|
|
The other is: <code>(let () (set! (outlet (curlet)) (curlet)))</code>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>If you want to hide an environment's fields from any part of s7 that does not
|
||
|
|
know the field names in advance,
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(openlet ; make it appear to be empty to the rest of s7
|
||
|
|
(inlet 'object->string (lambda args "#<let>")
|
||
|
|
'map (lambda args ())
|
||
|
|
'for-each (lambda args #<unspecified>)
|
||
|
|
'let->list (lambda args ())
|
||
|
|
'length (lambda args 0)
|
||
|
|
'copy (lambda args (inlet))
|
||
|
|
'open #t
|
||
|
|
'coverlet (lambda (e) (set! (e 'open) #f) e)
|
||
|
|
'openlet (lambda (e) (set! (e 'open) #t) e)
|
||
|
|
'openlet? (lambda (e) (e 'open))
|
||
|
|
;; your secret data here
|
||
|
|
))
|
||
|
|
</pre>
|
||
|
|
<p>(There are still at least two ways to tell that something is fishy).
|
||
|
|
</p>
|
||
|
|
<!-- add a field and it disappears, or sublet and read back -->
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>Here's one way to add a method to a closure:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define sf (let ((object->string (lambda (obj . arg)
|
||
|
|
"#<secret function!>")))
|
||
|
|
(openlet (lambda (x)
|
||
|
|
(+ x 1)))))
|
||
|
|
> sf
|
||
|
|
<em class="gray">#<secret function!></em>
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="multiplevalues"><h4>multiple-values</h4></div>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
In s7, multiple values are spliced directly into the caller's argument list.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (+ (values 1 2 3) 4)
|
||
|
|
<em class="gray">10</em>
|
||
|
|
> (string-ref ((lambda () (values "abcd" 2))))
|
||
|
|
<em class="gray">#\c</em>
|
||
|
|
> ((lambda (a b) (+ a b)) ((lambda () (values 1 2))))
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (+ (call/cc (lambda (ret) (ret 1 2 3))) 4) ; call/cc has an implicit "values"
|
||
|
|
<em class="gray">10</em>
|
||
|
|
> ((lambda* ((a 1) (b 2)) (list a b)) (values :a 3))
|
||
|
|
<em class="gray">(3 2)</em>
|
||
|
|
|
||
|
|
(define-macro (call-with-values producer consumer)
|
||
|
|
`(,consumer (,producer)))
|
||
|
|
|
||
|
|
(define-macro (multiple-value-bind vars expr . body)
|
||
|
|
`((lambda ,vars ,@body) ,expr))
|
||
|
|
|
||
|
|
(define-macro (define-values vars expression)
|
||
|
|
`(if (not (null? ',vars))
|
||
|
|
(varlet (curlet) ((lambda ,vars (curlet)) ,expression))))
|
||
|
|
|
||
|
|
(define (curry function . args)
|
||
|
|
(if (null? args)
|
||
|
|
function
|
||
|
|
(lambda more-args
|
||
|
|
(if (null? more-args)
|
||
|
|
(apply function args)
|
||
|
|
(function (apply values args) (apply values more-args))))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>multiple-values are useful in a several situations. For example,
|
||
|
|
<code>(if test (+ a b c) (+ a b d e))</code> can be written
|
||
|
|
<code>(+ a b (if test c (values d e)))</code>.
|
||
|
|
There are a few special uses of multiple-values.
|
||
|
|
First, you can use the values function to return any number of values, including 0,
|
||
|
|
from map's function application:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (map (lambda (x) (if (odd? x) (values x (* x 20)) (values))) (list 1 2 3))
|
||
|
|
<em class="gray">(1 20 3 60)</em>
|
||
|
|
> (map values (list 1 2 3) (list 4 5 6))
|
||
|
|
<em class="gray">(1 4 2 5 3 6)</em>
|
||
|
|
|
||
|
|
(define (remove-if func lst)
|
||
|
|
(map (lambda (x) (if (func x) (values) x)) lst))
|
||
|
|
|
||
|
|
(define (pick-mappings func lst)
|
||
|
|
(map (lambda (x) (or (func x) (values))) lst))
|
||
|
|
|
||
|
|
(define (shuffle . args)
|
||
|
|
(apply map values args))
|
||
|
|
|
||
|
|
> (shuffle '(1 2 3) #(4 5 6) '(7 8 9))
|
||
|
|
<em class="gray">(1 4 7 2 5 8 3 6 9)</em>
|
||
|
|
|
||
|
|
(define (concatenate . args)
|
||
|
|
(apply append (map (lambda (arg) (map values arg)) args)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Second, a macro can return multiple values; these are evaluated and spliced,
|
||
|
|
exactly like a normal macro,
|
||
|
|
so you can use <code>(values '(define a 1) '(define b 2))</code> to
|
||
|
|
splice multiple definitions at the macro invocation point.
|
||
|
|
If an expansion returns (values), nothing is spliced in. This is
|
||
|
|
mostly useful in <a href="#readercond">reader-cond</a> and the #; reader.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-expansion (comment str) (values))
|
||
|
|
<em class="gray">comment</em>
|
||
|
|
> (+ 1 (comment "one") 2 (comment "two"))
|
||
|
|
<em class="gray">3</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>At the top-level (in the REPL), since there's nothing to splice into, you simply get your values back:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (values 1 (list 1 2) (+ 3 4 5))
|
||
|
|
<em class="gray">(values 1 (1 2) 12)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>But this printout is just trying to be informative. There is no multiple-values object
|
||
|
|
in s7. You can't <code>(set! x (values 1 2))</code>, for example. The values function
|
||
|
|
tells s7 that its arguments should be handled in a special way, and the multiple-value indication goes away
|
||
|
|
as soon as the arguments are spliced into some caller's arguments.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p id="listvalues">There are two helper functions for multiple values, apply-values and list-values,
|
||
|
|
both intended primarily for quasiquote where (apply-values ...) implements what other schemes call unquote-splicing (",@...").
|
||
|
|
(apply-values lst) is like (apply values lst),
|
||
|
|
and (list-values ...) is like (list ...) except in one special case. It is common in writing macros
|
||
|
|
to create some piece of code to be spliced into the output, but if that code is nil, the resulting
|
||
|
|
macro code should contain nothing (not nil). apply-values and list-values cooperate with quasiquote to implement
|
||
|
|
this. As an example:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (list-values 1 2 (apply-values) 3)
|
||
|
|
<em class="gray">(1 2 3)</em>
|
||
|
|
> (define (supply . args) (apply-values args))
|
||
|
|
<em class="gray">supply</em>
|
||
|
|
> (define (consume f . args) (apply f (apply list-values args)))
|
||
|
|
<em class="gray">consume</em>
|
||
|
|
> (consume + (supply 1 2) (supply 3 4 5) (supply))
|
||
|
|
<em class="gray">15</em>
|
||
|
|
> (consume + (supply))
|
||
|
|
<em class="gray">0</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>It might seem simpler to return "nothing" from (values), rather than #<unspecified>,
|
||
|
|
but that has drawbacks. First, <code>(abs -1 (values))</code>, or worse <code>(abs (f x) (f y))</code>
|
||
|
|
is no longer an error at the level of the program text; you lose the ability to see at a glance that
|
||
|
|
a normal function has the right number of arguments. Second, a lot of code currently assumes that
|
||
|
|
(values) returns #<unspecified>, and that implies that <code>(apply values ())</code> does as well.
|
||
|
|
But it would be nice if <code>((lambda* ((x 1)) x) (values))</code> returned 1!
|
||
|
|
<!--
|
||
|
|
Is <code>(apply apply func arglist)</code> the same as <code>(apply func (apply values arglist))</code>,
|
||
|
|
or (leaving aside <code>'(()))</code>, <code>(func (apply values (apply values arglist)))</code>?
|
||
|
|
-->
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Since set! does not evaluate its first argument, and
|
||
|
|
there is no setter for "values", <code>(set! (values x) ...)</code> is not
|
||
|
|
the same as <code>(set! x ...)</code>. <code>(string-set! (values string) ...)</code>
|
||
|
|
works because string-set! does evaluate its first argument. <code>((values + 1 2) (values 3 4) 5)</code>
|
||
|
|
is 15, as anyone would expect.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<p>One problem with this way of handling multiple values involves cases where you can't
|
||
|
|
tell whether an expression will return multiple values. Then you have, for example, <code>(let ((val (expr)))...)</code>
|
||
|
|
and need to accept either a normal single value from <code>expr</code>, or one member of the
|
||
|
|
possible set of multiple values. In lint.scm, I'm currently handling this with lambda:
|
||
|
|
<code>(let ((val ((lambda args (car args)) (expr))))...)</code>, but this feels kludgey.
|
||
|
|
CL has nth-value which appears to do "the right thing" in this context; perhaps s7 needs
|
||
|
|
it too.
|
||
|
|
</p>
|
||
|
|
<p>A similar difficulty arises in <code>(if (expr) ...)</code> where <code>(expr)</code> might
|
||
|
|
return multiple values. CL (or sbcl anyway) treats this as if it were wrapped in <code>(nth-value 0 (expr))</code>.
|
||
|
|
Splicing the values in, on the other hand, could lead to disaster: there would be no way to tell from the code
|
||
|
|
that the if statement
|
||
|
|
was valid, or which branch would be taken! So, in those cases where a syntactic form evaluates
|
||
|
|
an argument, s7 follows CL, and uses only the first of the values (this affects if, when, unless, cond, and case).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="callwithexit1"><h4>call-with-exit, with-baffle and continuation?</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<p><b><em class="def" id="callwithexit">call-with-exit</em></b> is call/cc without the ability to jump back into the original context,
|
||
|
|
similar to "return" in C. This
|
||
|
|
is cleaner than call/cc, and much faster.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define-macro (block . body)
|
||
|
|
;; borrowed loosely from CL — predefine "return" as an escape
|
||
|
|
`(<em class="red">call-with-exit</em> (lambda (return) ,@body)))
|
||
|
|
|
||
|
|
(define-macro (while test . body) ; while loop with predefined break and continue
|
||
|
|
`(<em class="red">call-with-exit</em>
|
||
|
|
(lambda (break)
|
||
|
|
(let continue ()
|
||
|
|
(if (let () ,test)
|
||
|
|
(begin
|
||
|
|
(let () ,@body)
|
||
|
|
(continue))
|
||
|
|
(break))))))
|
||
|
|
|
||
|
|
(define-macro (switch selector . clauses) ; C-style case (branches fall through unless break called)
|
||
|
|
`(<em class="red">call-with-exit</em>
|
||
|
|
(lambda (break)
|
||
|
|
(case ,selector
|
||
|
|
,@(do ((clause clauses (cdr clause))
|
||
|
|
(new-clauses ()))
|
||
|
|
((null? clause) (reverse new-clauses))
|
||
|
|
(set! new-clauses (cons `(,(caar clause)
|
||
|
|
,@(cdar clause)
|
||
|
|
,@(map (lambda (nc)
|
||
|
|
(apply values (cdr nc))) ; doubly spliced!
|
||
|
|
(if (pair? clause) (cdr clause) ())))
|
||
|
|
new-clauses)))))))
|
||
|
|
|
||
|
|
(define (and-for-each func . args)
|
||
|
|
;; apply func to the first member of each arg, stopping if it returns #f
|
||
|
|
(<em class="red">call-with-exit</em>
|
||
|
|
(lambda (quit)
|
||
|
|
(apply for-each (lambda arglist
|
||
|
|
(if (not (apply func arglist))
|
||
|
|
(quit #<unspecified>)))
|
||
|
|
args))))
|
||
|
|
|
||
|
|
(define (find-if f . args) ; generic position-if is very similar
|
||
|
|
(<em class="red">call-with-exit</em>
|
||
|
|
(lambda (return)
|
||
|
|
(apply for-each (lambda main-args
|
||
|
|
(if (apply f main-args)
|
||
|
|
(apply return main-args)))
|
||
|
|
args))))
|
||
|
|
|
||
|
|
> (find-if even? #(1 3 5 2))
|
||
|
|
<em class="gray">2</em>
|
||
|
|
> (* (find-if > #(1 3 5 2) '(2 2 2 3)))
|
||
|
|
<em class="gray">6</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
The call-with-exit function's argument (the "continuation") is only valid
|
||
|
|
within the call-with-exit function. In call/cc, you can save it, then call it later
|
||
|
|
to jump back, but if you try that with call-with-exit (from outside the call-with-exit function's body), you'll get an error.
|
||
|
|
This is similar to trying to read from a closed input port.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<p>The other side, so to speak, of call-with-exit, is <em class="def" id="withbaffle">with-baffle</em>.
|
||
|
|
Sometimes we need a normal call/cc, but want to make sure it is active
|
||
|
|
only within a given block of code.
|
||
|
|
Normally, if a continuation gets away, there's no telling when it might wreak havoc on us.
|
||
|
|
with-baffle blocks that — no continuation can jump into its body:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(let ((what's-for-breakfast ())
|
||
|
|
(bad-dog 'fido)) ; bad-dog wonders what's for breakfast?
|
||
|
|
(<em class="red">with-baffle</em> ; the syntax is (with-baffle . body)
|
||
|
|
(set! what's-for-breakfast
|
||
|
|
(call/cc
|
||
|
|
(lambda (biscuit?)
|
||
|
|
(set! bad-dog biscuit?) ; bad-dog smells a biscuit!
|
||
|
|
'biscuit!))))
|
||
|
|
(if (eq? what's-for-breakfast 'biscuit!)
|
||
|
|
(bad-dog 'biscuit!)) ; now, outside the baffled block, bad-dog wants that biscuit!
|
||
|
|
what's-for-breakfast) ; but s7 says "No!": baffled! ("continuation can't jump into with-baffle")
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<br>
|
||
|
|
<p><em class="def" id="continuationp">continuation?</em> returns #t if its argument is a continuation,
|
||
|
|
as opposed to a normal procedure. I don't know why Scheme hasn't had this function from
|
||
|
|
the very beginning, but it's needed if you want to write a continuable error
|
||
|
|
handler. Here is a sketch of the situation:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(catch #t
|
||
|
|
(lambda ()
|
||
|
|
(let ((res (call/cc
|
||
|
|
(lambda (ok)
|
||
|
|
(error 'cerror "an error" ok)))))
|
||
|
|
(display res) (newline)))
|
||
|
|
(lambda args
|
||
|
|
(when (and (eq? (car args) 'cerror)
|
||
|
|
(<em class="red">continuation?</em> (cadadr args)))
|
||
|
|
(display "continuing...")
|
||
|
|
((cadadr args) 2))
|
||
|
|
(display "oops")))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>In a more general case, the error handler is separate from the
|
||
|
|
catch body, and needs a way to distinguish a real continuation
|
||
|
|
from a simple procedure.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define (continuable-error . args)
|
||
|
|
(call/cc
|
||
|
|
(lambda (continue)
|
||
|
|
(apply error args))))
|
||
|
|
|
||
|
|
(define (continue-from-error)
|
||
|
|
(if (<em class="red">continuation?</em> ((owlet) 'continue)) ; might be #<undefined> or a function as in the while macro
|
||
|
|
(((owlet) 'continue))
|
||
|
|
'bummer))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<!--
|
||
|
|
(define-macro (call-with-exit func)
|
||
|
|
(let ((tag (caadr func)))
|
||
|
|
`(catch ',tag
|
||
|
|
(lambda ()
|
||
|
|
(define-macro (,tag . body)
|
||
|
|
`(throw ',',tag ,@body))
|
||
|
|
,@(cddr func))
|
||
|
|
(lambda (type info)
|
||
|
|
(car info)))))
|
||
|
|
-->
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="format1"><h4>format, object->string</h4></div>
|
||
|
|
|
||
|
|
<p>object->string returns the string representation of its argument. Its optional second argument
|
||
|
|
can be #f or :display (use display), #t or :write (the default, use write), or :readable. In the latter case, object->string
|
||
|
|
tries to produce a string that can be evaluated via eval-string to return an object equal to the
|
||
|
|
original. The optional third argument sets the maximum desired string length; if object->string
|
||
|
|
notices it has exceeded this limit, it returns the partial string.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (object->string "hiho")
|
||
|
|
<em class="gray">"\"hiho\""</em>
|
||
|
|
> (format #f "~S" "hiho")
|
||
|
|
<em class="gray">"\"hiho\""</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<br>
|
||
|
|
<p>s7's <em class="def" id="format">format</em> function is very close to that in srfi-48.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (format #f "~A ~D ~F" 'hi 123 3.14)
|
||
|
|
<em class="gray">"hi 123 3.140000"</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<p>The format directives (tilde chars) are:</p>
|
||
|
|
<pre class="indented">~% insert newline
|
||
|
|
~& insert newline if preceding char was not newline
|
||
|
|
~~ insert tilde
|
||
|
|
~\n (tilde followed by newline): trim white space
|
||
|
|
~{ begin iteration (take arguments from a list, string, vector, or any other applicable object)
|
||
|
|
~} end iteration
|
||
|
|
~^ ~| jump out of iteration
|
||
|
|
~* ignore the current argument
|
||
|
|
~C print character (numeric argument = how many times to print it)
|
||
|
|
~P insert 's' if current argument is not 1 or 1.0 (use ~@P for "ies" or "y")
|
||
|
|
~A object->string as in display
|
||
|
|
~S object->string as in write
|
||
|
|
~B number->string in base 2
|
||
|
|
~O number->string in base 8
|
||
|
|
~D number->string in base 10 (~:D for ordinal)
|
||
|
|
~X number->string in base 16
|
||
|
|
~E float to string, (format #f "~E" 100.1) -> "1.001000e+02", (%e in C)
|
||
|
|
~F float to string, (format #f "~F" 100.1) -> "100.100000", (%f in C)
|
||
|
|
~G float to string, (format #f "~G" 100.1) -> "100.1", (%g in C)
|
||
|
|
~T insert spaces (padding)
|
||
|
|
~N get numeric argument from argument list (similar to ~V in CL)
|
||
|
|
~W object->string with :readable (write readably: "serialization"; s7 is the intended reader)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The eight directives before ~W take the usual numeric arguments to specify field width and precision.
|
||
|
|
These can also be ~N or ~n in which case the numeric argument is read from the list of arguments:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(format #f "~ND" 20 1234) ; => (format "~20D" 1234)
|
||
|
|
<em class="gray">" 1234"</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<code>(format #f ...)</code> simply returns the formatted string; <code>(format #t ...)</code>
|
||
|
|
also sends the string to the current-output-port. <code>(format () ...)</code> sends the output to
|
||
|
|
the current-output-port without returning the string (this mimics the other IO routines
|
||
|
|
such as display and newline). Other built-in port choices are *stdout* and *stderr*.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Floats can occur in any base, so:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> #xf.c
|
||
|
|
<em class="gray">15.75</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>This also affects format. In most Schemes, <code>(format #f "~X" 1.25)</code> is
|
||
|
|
an error. In CL, it is equivalent to using ~A which is perverse. But
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (number->string 1.25 16)
|
||
|
|
<em class="gray">"1.4"</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>and there's no obvious way to get the same effect from format unless we accept
|
||
|
|
floats in the "~X" case. So in s7,
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (format #f "~X" 21)
|
||
|
|
<em class="gray">"15"</em>
|
||
|
|
> (format #f "~X" 1.25)
|
||
|
|
<em class="gray">"1.4"</em>
|
||
|
|
> (format #f "~X" 1.25+i)
|
||
|
|
<em class="gray">"1.4+1.0i"</em>
|
||
|
|
> (format #f "~X" 21/4)
|
||
|
|
<em class="gray">"15/4"</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>That is, the output choice matches the argument. A case that came up in the Guile mailing lists is:
|
||
|
|
<code>(format #f "~F" 1/3)</code>. s7 currently returns "1/3", but Clisp returns "0.33333334".
|
||
|
|
</p>
|
||
|
|
<br>
|
||
|
|
<p>The curly bracket directive applies to anything you can map over, not just lists:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (format #f "~{~C~^ ~}" "hiho")
|
||
|
|
<em class="gray">"h i h o"</em>
|
||
|
|
> (format #f "~{~{~C~^ ~}~^...~}" (list "hiho" "test"))
|
||
|
|
<em class="gray">"h i h o...t e s t"</em>
|
||
|
|
> (with-input-from-string (format #f "(~{~C~^ ~})" (format #f "~B" 1367)) read) ; integer->list
|
||
|
|
<em class="gray">(1 0 1 0 1 0 1 0 1 1 1)</em>
|
||
|
|
</pre>
|
||
|
|
<br>
|
||
|
|
|
||
|
|
<p>Since any sequence can be passed to ~{~}, we need a way to truncate output and represent
|
||
|
|
the rest of the sequence with "...", but ~^ only stops at the end of the sequence. ~|
|
||
|
|
is like ~^ but it also stops after it handles (*s7* 'print-length) elements and prints
|
||
|
|
"...". So, <code>(format #f "~{~A~| ~}" #(0 1 2 3 4))</code> returns "0 1 2 ..."
|
||
|
|
if (*s7* 'print-length) is 3.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>I added object->string to s7 before deciding to include format. format excites a
|
||
|
|
vague disquiet — why do we need this ancient unlispy thing?
|
||
|
|
We can almost replace it with:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define (objects->string . objects)
|
||
|
|
(apply string-append (map (lambda (obj) (object->string obj #f)) objects)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>But how to handle lists (~{...~} in format), or columnized output (~T)?
|
||
|
|
I wonder whether formatted string output still matters outside a REPL. Even in that context,
|
||
|
|
a modern GUI leaves formatting decisions to a text or table widget.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define-macro (string->objects str . objs)
|
||
|
|
`(with-input-from-string ,str
|
||
|
|
(lambda ()
|
||
|
|
,@(map (lambda (obj)
|
||
|
|
`(set! ,obj (eval (read))))
|
||
|
|
objs))))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>format is a mess. It is trying to cram two different choices into its first ("port") argument.
|
||
|
|
Perhaps it should be split into format->string and format->port. format->string has no
|
||
|
|
port argument and returns a string. format->port writes to its port argument (which must be an output
|
||
|
|
port, not a boolean), and returns #f or maybe <unspecified>. Then:
|
||
|
|
</p>
|
||
|
|
<pre>(format #f ...) -> (format->string ...)
|
||
|
|
(format () ...) -> (format->port (current-output-port) ...)
|
||
|
|
(format #t ...) -> (display (format->string ...))
|
||
|
|
(format port ...) -> (display (format->string ...) port)
|
||
|
|
</pre>
|
||
|
|
<p>and the currently unavailable choice, format to port without creating a string:
|
||
|
|
<code>(format->port port ...)</code>.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
<!--
|
||
|
|
|
||
|
|
:(objects->string "int: " 32 ", string: " "hi")
|
||
|
|
"int: 32, string: hi"
|
||
|
|
|
||
|
|
(define (cycle->string . objs)
|
||
|
|
(call-with-exit
|
||
|
|
(lambda (return)
|
||
|
|
(for-each
|
||
|
|
(lambda (obj)
|
||
|
|
(if (pair? obj)
|
||
|
|
(return
|
||
|
|
(string-append
|
||
|
|
(apply objects->string
|
||
|
|
(map (lambda (obj)
|
||
|
|
(if (pair? obj)
|
||
|
|
(car obj)
|
||
|
|
obj))
|
||
|
|
objs))
|
||
|
|
(apply cycle->string
|
||
|
|
(map (lambda (obj)
|
||
|
|
(if (pair? obj)
|
||
|
|
(cdr obj)
|
||
|
|
obj))
|
||
|
|
objs))))))
|
||
|
|
objs)
|
||
|
|
"")))
|
||
|
|
|
||
|
|
;;; (cycle->string ": " (list 1 2 3) " |")
|
||
|
|
:(objects->string "int: " 32 ", list with spaces: (" (cycle->string (list 1 2 3) " ") "), string: " "hi")
|
||
|
|
"int: 32, list with spaces: (1 2 3 ), string: hi"
|
||
|
|
|
||
|
|
:(let ((x 0) (y 0)) (string->objects "1 2" x y) (list x y))
|
||
|
|
(1 2)
|
||
|
|
|
||
|
|
-->
|
||
|
|
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="hooks"><h4>hooks</h4></div>
|
||
|
|
|
||
|
|
<pre class="indented">(<em class="def" id="makehook">make-hook</em> . fields) ; make a new hook
|
||
|
|
(<em class="def" id="hookfunctions">hook-functions</em> hook) ; the hook's list of 'body' functions
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>A hook is a function created by make-hook, and called (normally from C) when something interesting happens.
|
||
|
|
In GUI toolkits hooks are called callback-lists, in CL conditions,
|
||
|
|
in other contexts watchpoints or signals. s7 itself has several
|
||
|
|
hooks: <a href="#errorhook">*error-hook*</a>, <a href="#readerrorhook">*read-error-hook*</a>,
|
||
|
|
<a href="#unboundvariablehook">*unbound-variable-hook*</a>, *missing-close-paren-hook*, *rootlet-redefinition-hook*,
|
||
|
|
<a href="#loadhook">*load-hook*</a>, and *autoload-hook*.
|
||
|
|
make-hook is:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define (make-hook . args)
|
||
|
|
(let ((body ()))
|
||
|
|
(apply lambda* args
|
||
|
|
'(let ((result #<unspecified>))
|
||
|
|
(let ((e (curlet)))
|
||
|
|
(for-each (lambda (f) (f e)) body)
|
||
|
|
result))
|
||
|
|
())))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>So the result of calling make-hook is a function (the lambda* that is applied to args above) that
|
||
|
|
contains a list of functions, 'body.
|
||
|
|
Each function in that list takes one argument, the hook.
|
||
|
|
Each time the hook itself is called, each of the body functions is called, and the value of 'result is returned.
|
||
|
|
That variable, and each of the hook's arguments are accessible to the hook's internal
|
||
|
|
functions by going through the environment passed to the internal functions. This is a bit circuitous;
|
||
|
|
here's a sketch:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define h (make-hook '(a 32) 'b)) ; h is a function: (lambda* ((a 32) b) ...)
|
||
|
|
<em class="gray">h</em>
|
||
|
|
> (set! (hook-functions h) ; this sets ((funclet h) 'body)
|
||
|
|
(list (lambda (hook) ; each hook internal function takes one argument, the environment
|
||
|
|
(set! (hook 'result) ; this is the "result" variable above
|
||
|
|
(format #f "a: ~S, b: ~S" (hook 'a) (hook 'b))))))
|
||
|
|
<em class="gray">(#<lambda (hook)>)</em>
|
||
|
|
> (h 1 2) ; this calls the hook's internal functions (just one in this case)
|
||
|
|
<em class="gray">"a: 1, b: 2" ; we set "result" to this string, so it is returned as the hook application result</em>
|
||
|
|
> (h)
|
||
|
|
<em class="gray">"a: 32, b: #f"</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>In C, to make a hook:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">hook = s7_eval_c_string("(make-hook '(a 32) 'b)");
|
||
|
|
s7_gc_protect(s7, hook);
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>And call it:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">result = s7_call(s7, hook, s7_list(s7, 2, s7_make_integer(s7, 1), s7_make_integer(s7, 2)));
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>(define-macro (hook . body) ; return a new hook with "body" as its body, setting "result"
|
||
|
|
`(let ((h (make-hook)))
|
||
|
|
(set! (hook-functions h) (list (lambda (h) (set! (h 'result) (begin ,@body)))))
|
||
|
|
h))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="variableinfo"><h4>variable info</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<pre class="indented">(<em class="def" id="documentation">documentation</em> obj) ; old name: (procedure-documentation obj)
|
||
|
|
(<em class="def" id="signature">signature</em> obj) ; old: (procedure-signature obj)
|
||
|
|
(<em class="def" id="setter">setter</em> obj) ; old: (procedure-setter obj)
|
||
|
|
(<em class="def" id="arity">arity</em> obj) ; very old: (procedure-arity obj)
|
||
|
|
(<em class="def" id="aritablep">aritable?</em> obj num-args)
|
||
|
|
(funclet proc)
|
||
|
|
(<em class="def" id="proceduresource">procedure-source</em> proc)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b>funclet</b> returns
|
||
|
|
a procedure's environment.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (funclet (let ((b 32)) (lambda (a) (+ a b))))
|
||
|
|
<em class="gray">(inlet 'b 32)</em>
|
||
|
|
> (funclet abs)
|
||
|
|
<em class="gray">(rootlet)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b>setter</b> returns or sets the set function associated with a procedure (set-car! with car, for example).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b>procedure-source</b> returns the procedure source (a list):
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (procedure-arglist f) (cadr (procedure-source f)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b>documentation</b> returns the documentation string associated with a procedure. This used to be
|
||
|
|
the initial string in the function's body (as in CL), but now it is the value of the '+documentation+ variable, if any,
|
||
|
|
in the procedure's local environment:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define func
|
||
|
|
(let ((+documentation+ "helpful info"))
|
||
|
|
(lambda (a) a)))
|
||
|
|
|
||
|
|
> (documentation func)
|
||
|
|
<em class="gray">"helpful info"</em>
|
||
|
|
</pre>
|
||
|
|
<p>Since documentation is a method, a function's documentation can be computed at run-time:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define func
|
||
|
|
(let ((documentation (lambda (f) (format #f "this is func's funclet: ~S" (funclet f)))))
|
||
|
|
(lambda (x)
|
||
|
|
(+ x 1))))
|
||
|
|
|
||
|
|
> (documentation func)
|
||
|
|
<em class="gray">"this is func's funclet: (inlet 'x ())"</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b>arity</b> takes any object and returns either #f if it is not applicable,
|
||
|
|
or a cons containing the minimum and maximum number of arguments acceptable. If the maximum reported
|
||
|
|
is a really big number, that means any number of arguments is ok.
|
||
|
|
<b>aritable?</b> takes two arguments, an object and an integer, and returns #t if the object can be
|
||
|
|
applied to that many arguments.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define* (add-2 a (b 32)) (+ a b))
|
||
|
|
<em class="gray">add-2</em>
|
||
|
|
> (procedure-source add-2)
|
||
|
|
<em class="gray">(lambda* (a (b 32)) (+ a b))</em>
|
||
|
|
> (arity add-2)
|
||
|
|
<em class="gray">(0 . 2)</em>
|
||
|
|
> (aritable? add-2 1)
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b>signature</b> is a list describing the argument types and returned value type
|
||
|
|
of the function. The first entry in the list is the return type, and the rest are
|
||
|
|
argument types. #t means any type is possible, and 'values means the function returns multiple values.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (signature round)
|
||
|
|
<em class="gray">(integer? real?)</em> ; round takes a real argument, returns an integer
|
||
|
|
> (signature vector-ref)
|
||
|
|
<em class="gray">(#t vector? . #1=(integer? . #1#))</em> ; trailing args are all integers (indices)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>If an entry is a list, any of the listed types can occur:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (signature char-position)
|
||
|
|
<em class="gray">((boolean? integer?) (char? string?) string? integer?)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>which says that the first argument to char-position can be a string or a character,
|
||
|
|
and the return type can be either boolean or an integer. If we know a function returns
|
||
|
|
multiple values, the return type (first element of the signature) can contain a list
|
||
|
|
describing each such value: <code>(define (f x) (values (floor x) (ceiling x)))</code>
|
||
|
|
could be <code>(((integer?) (integer?)) real?)</code>.
|
||
|
|
</p>
|
||
|
|
<p>
|
||
|
|
If the function is defined in scheme, its signature is the value of the '+signature+ variable
|
||
|
|
in its closure:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define f1 (let ((+documentation+ "helpful info")
|
||
|
|
(+signature+ '(boolean? real?)))
|
||
|
|
(lambda (x)
|
||
|
|
(positive? x))))
|
||
|
|
<em class="gray">f1</em>
|
||
|
|
> (documentation f1)
|
||
|
|
<em class="gray">"helpful info"</em>
|
||
|
|
> (signature f1)
|
||
|
|
<em class="gray">(boolean? real?)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>We could do the same thing using methods:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define f1 (let ((documentation (lambda (f) "helpful info"))
|
||
|
|
(signature (lambda (f) '(boolean? real?))))
|
||
|
|
(<em class="red">openlet</em> ; openlet alerts s7 that f1 has methods
|
||
|
|
(lambda (x)
|
||
|
|
(positive? x)))))
|
||
|
|
> (documentation f1)
|
||
|
|
<em class="gray">"helpful info"</em>
|
||
|
|
> (signature f1)
|
||
|
|
<em class="gray">(boolean? real?)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>signature could also be used to implement CL's 'the:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define-macro (the value-type form)
|
||
|
|
`((let ((+signature+ (list ,value-type)))
|
||
|
|
(lambda ()
|
||
|
|
,form))))
|
||
|
|
|
||
|
|
(display (+ 1 (<em class="red">the</em> integer? (+ 2 3))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>but the optimizer currently doesn't know how to take advantage of this pattern.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>You can obviously add your own methods:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define my-add
|
||
|
|
(let ((<em class="red">tester</em> (lambda ()
|
||
|
|
(if (not (= (my-add 2 3) 5))
|
||
|
|
(format #t "oops: (myadd 2 3) -> ~A~%"
|
||
|
|
(my-add 2 3))))))
|
||
|
|
(lambda (x y)
|
||
|
|
(- x y))))
|
||
|
|
|
||
|
|
(define (auto-test) ; scan the symbol table for procedures with testers
|
||
|
|
(let ((st (symbol-table)))
|
||
|
|
(for-each (lambda (f)
|
||
|
|
(let* ((fv (and (defined? f)
|
||
|
|
(symbol->value f)))
|
||
|
|
(testf (and (procedure? fv)
|
||
|
|
((funclet fv) '<em class="red">tester</em>))))
|
||
|
|
(when (procedure? testf) ; found one!
|
||
|
|
(testf))))
|
||
|
|
st)))
|
||
|
|
|
||
|
|
> (auto-test)
|
||
|
|
<em class="gray">oops: (myadd 2 3) -> -1</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Even the setter can be set this way:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define flocals
|
||
|
|
(let ((x 1))
|
||
|
|
(let ((+setter+ (lambda (val) (set! x val))))
|
||
|
|
(lambda ()
|
||
|
|
x))))
|
||
|
|
|
||
|
|
> (flocals)
|
||
|
|
<em class="gray">1</em>
|
||
|
|
> (setter flocals)
|
||
|
|
<em class="gray">#<lambda (val)></em>
|
||
|
|
> (set! (flocals) 32)
|
||
|
|
<em class="gray">32</em>
|
||
|
|
> (flocals)
|
||
|
|
<em class="gray">32</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<br>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<pre>(define (for-each-subset func args)
|
||
|
|
;; form each subset of args, apply func to the subsets that fit its arity
|
||
|
|
(let subset ((source args)
|
||
|
|
(dest ())
|
||
|
|
(len 0))
|
||
|
|
(if (null? source)
|
||
|
|
(if (<em class="red">aritable?</em> func len) ; does this subset fit?
|
||
|
|
(apply func dest))
|
||
|
|
(begin
|
||
|
|
(subset (cdr source) (cons (car source) dest) (+ len 1))
|
||
|
|
(subset (cdr source) dest len)))))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="evalstring"><h4>eval</h4></div>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b>eval</b> evaluates its argument, a list representing a piece of code. It takes an optional
|
||
|
|
second argument, the environment in which the evaluation should take place. <b>eval-string</b>
|
||
|
|
is similar, but its argument is a string.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (eval '(+ 1 2))
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (eval-string "(+ 1 2)")
|
||
|
|
<em class="gray">3</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Leaving aside a few special cases, eval-string could be defined:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define-macro* (eval-string x e)
|
||
|
|
`(eval (with-input-from-string ,x read) (or ,e (curlet))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="IO"><h4>IO and other OS functions</h4></div>
|
||
|
|
|
||
|
|
<p>Besides files, ports can also represent strings and functions. The string port functions
|
||
|
|
are:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(with-output-to-string thunk) ; open a string port as current-output-port, call thunk, return string
|
||
|
|
(with-input-from-string string thunk) ; open string as current-input-port, call thunk
|
||
|
|
(call-with-output-string proc) ; open a string port, apply proc to it, return string
|
||
|
|
(call-with-input-string string proc) ; open string as current-input-port, apply proc to it
|
||
|
|
(open-output-string) ; open a string output port
|
||
|
|
(get-output-string port clear) ; return output accumulated in the string output port
|
||
|
|
(open-input-string string) ; open a string input port reading string
|
||
|
|
(<em class="def" id="openinputfunction">open-input-function</em> function) ; open a function input port
|
||
|
|
(<em class="def" id="openoutputfunction">open-output-function</em> function) ; open a function output port
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((result #f)
|
||
|
|
(p (<em class="red">open-output-string</em>)))
|
||
|
|
(format p "this ~A ~C test ~D" "is" #\a 3)
|
||
|
|
(set! result (<em class="red">get-output-string</em> p))
|
||
|
|
(close-output-port p)
|
||
|
|
result)
|
||
|
|
<em class="gray">"this is a test 3"</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>In get-output-string, if the optional 'clear' argument is #t, the port is cleared (the default in r7rs I think).
|
||
|
|
Other functions:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<ul>
|
||
|
|
<li>read-byte and write-byte: binary IO
|
||
|
|
</li><li>read-line: line-at-a-time reads, optional second argument #t to include the newline
|
||
|
|
</li><li>read-string (r7rs)
|
||
|
|
</li><li>current-error-port, set-current-error-port
|
||
|
|
</li><li><em class="def" id="portfilename">port-filename</em> and
|
||
|
|
<em class="def" id="portlinenumber">port-line-number</em> (input ports)
|
||
|
|
</li><li><em class="def" id="portposition">port-position</em> (input port, settable)
|
||
|
|
</li><li><em class="def" id="portfile">port-file</em>
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
<p>Use length to get the length in bytes of an input port's file or string.
|
||
|
|
port-line-number is settable (for fancy *#readers*).
|
||
|
|
<b>port-position</b> is the position in bytes of the reader in the port. It is settable.
|
||
|
|
<b>port-file</b> is intended for use with the *libc* library. It returns a c-pointer
|
||
|
|
containing the FILE* pointer associated with the file port (except in Windows):
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(call-with-input-file "s7test.scm"
|
||
|
|
(lambda (p)
|
||
|
|
(with-let (sublet *libc* :file (<em class="red">port-file</em> p))
|
||
|
|
(fseek file 1000 SEEK_SET))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The variable (*s7* 'print-length) sets
|
||
|
|
the upper limit on how many elements of a sequence are printed by object->string and format.
|
||
|
|
When running s7 behind a GUI, you often want input to come from and output to go to
|
||
|
|
arbitrary widgets. The function ports provide a way to redirect IO in C. See <a href="#functionportexample">below</a>
|
||
|
|
for an example.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>The function ports call a function rather than reading or writing the data to a string or file.
|
||
|
|
See nrepl.scm and s7test.scm for examples. The function-port function is accessible as
|
||
|
|
<code>((object->let function-port) 'function)</code>. These ports are even more esoteric than
|
||
|
|
their C-side cousins. An example that traps current-ouput-port output:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(let* ((str ())
|
||
|
|
(stdout-wrapper (open-output-function
|
||
|
|
(lambda (c)
|
||
|
|
(set! str (cons c str))))))
|
||
|
|
(let-temporarily (((current-output-port) stdout-wrapper))
|
||
|
|
(write-char #\a)
|
||
|
|
...))
|
||
|
|
</pre>
|
||
|
|
<blockquote>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>
|
||
|
|
The end-of-file object is #<eof>.
|
||
|
|
When the read function encounters the constant #<eof> it returns #<eof>.
|
||
|
|
This is neither inconsistent nor unusual: read returns either a form or
|
||
|
|
#<eof>. If read encounters a form that contains #<eof>, it returns a
|
||
|
|
form containing #<eof>, just as with any other constant.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (with-input-from-string "(or x #<eof>)" read)
|
||
|
|
<em class="gray">(or x #<eof>)</em>
|
||
|
|
> (eof-object? (with-input-from-string "'#<eof>" read))
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>If read hits the end of
|
||
|
|
the input while reading a form, it raises an error (e.g. "missing close paren").
|
||
|
|
If it encounters
|
||
|
|
#<eof> all by itself at the top level (this never happens),
|
||
|
|
it returns that #<eof>. But this is specific to read, not (for example) load:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">;; say we have "t234.scm" with:
|
||
|
|
(display "line 1") (newline)
|
||
|
|
#<eof>
|
||
|
|
(display "line 2") (newline)
|
||
|
|
;; end of t234.scm
|
||
|
|
|
||
|
|
> (load "t234.scm")
|
||
|
|
<em class="gray">line 1
|
||
|
|
line 2</em>
|
||
|
|
|
||
|
|
(with-input-from-file "t234.scm"
|
||
|
|
(lambda ()
|
||
|
|
(do ((c (read) (read)))
|
||
|
|
((eof-object? c))
|
||
|
|
(eval c))))
|
||
|
|
<em class="gray">line 1</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
Built-in #<eof> has lots of
|
||
|
|
uses, and as far as I can see, no drawbacks. For example,
|
||
|
|
it is common to call
|
||
|
|
read (or one of its friends) in a loop which first checks for #<eof>, then falls into
|
||
|
|
a case statement. In s7, we can dispense with the extra if (and let), and include
|
||
|
|
the #<eof> in the case statement: <code>(case (read-char) ((#<eof>) (quit-reading)) ((#\a)...))</code>.
|
||
|
|
Another example: <code>(or (eof-object? x) (eqv x 24)...)</code> can be instead: <code>(memv x '(#<eof> 24 ...)</code>.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>
|
||
|
|
The default IO ports are *stdin*, *stdout*, and *stderr*.
|
||
|
|
*stderr* is useful if you want to make sure output is flushed out immediately.
|
||
|
|
The default output port is *stdout* which buffers output until a newline is seen.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>An environment can be treated as an IO port, providing what Guile calls a "soft port":
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define (call-with-input-vector v proc)
|
||
|
|
(let ((i -1))
|
||
|
|
(proc (openlet (inlet 'read (lambda (p) (v (set! i (+ i 1)))))))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Here the IO port is an open environment that redefines the "read" function so that it
|
||
|
|
returns the next element of a vector. See stuff.scm for call-with-output-vector.
|
||
|
|
The "proc" argument above can also be a macro, giving you a kludgey way to get around
|
||
|
|
the dumb "lambda". Here are more useful examples:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(openlet ; a soft port for format that sends its output to *stderr* and returns the string
|
||
|
|
(inlet 'format (lambda (port str . args)
|
||
|
|
(apply format *stderr* str args))))
|
||
|
|
|
||
|
|
(define (open-output-log name)
|
||
|
|
;; return a soft output port that does not hold its output file open
|
||
|
|
(define (logit name str)
|
||
|
|
(let ((p (open-output-file name "a")))
|
||
|
|
(display str p)
|
||
|
|
(close-output-port p)))
|
||
|
|
(openlet
|
||
|
|
(inlet :name name
|
||
|
|
:format (lambda (p str . args) (logit (p 'name) (apply format #f str args)))))))
|
||
|
|
:write (lambda (obj p) (logit (p 'name) (object->string obj #t)))
|
||
|
|
:display (lambda (obj p) (logit (p 'name) (object->string obj #f)))
|
||
|
|
:write-string (lambda (str p) (logit (p 'name) str))
|
||
|
|
:write-char (lambda (ch p) (logit (p 'name) (string ch)))
|
||
|
|
:newline (lambda (p) (logit (p 'name) (string #\newline)))
|
||
|
|
:output-port? (lambda (p) #t)
|
||
|
|
:close-output-port (lambda (p) #f)
|
||
|
|
:flush-output-port (lambda (p) #f)
|
||
|
|
|
||
|
|
(let ((p (open-output-log "logit.data")))
|
||
|
|
(format p "this is a test~%")
|
||
|
|
(format p "line: ~A~%" 2))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>binary-io.scm in the Snd package has functions that read and write integers and floats in
|
||
|
|
both endian choices in a variety of sizes.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
<p>If the compile time switch WITH_SYSTEM_EXTRAS is 1, several additional OS-related and
|
||
|
|
file-related functions are built-in. This is work in progress; currently this switch
|
||
|
|
adds:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(directory? str) ; return #t if str is the name of a directory
|
||
|
|
(file-exists? str) ; return #t if str names an existing file
|
||
|
|
(delete-file str) ; try to delete the file, return 0 is successful, else -1
|
||
|
|
(getenv var) ; return the value of an environment variable: (getenv "HOME")
|
||
|
|
(directory->list dir) ; return contents of directory as a list of strings (if HAVE_DIRENT_H)
|
||
|
|
(system command) ; execute command
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>But maybe this is not needed; see <a href="#cload">cload.scm</a> below for
|
||
|
|
a more direct approach.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="errors"><h4>error handling</h4></div>
|
||
|
|
|
||
|
|
<pre class="indented">(error tag . info) ; signal an error of type tag with addition information
|
||
|
|
(catch tag body err) ; if error of type tag signalled in body (a thunk), call err with tag and info
|
||
|
|
(throw tag . info) ; jump to corresponding catch
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>s7's error handling mimics that of Guile. An error is signalled
|
||
|
|
via the error function, and can be trapped and dealt with via <em class="def" id="catch">catch</em>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (<em class="red">catch</em> 'wrong-number-of-args
|
||
|
|
(lambda () ; code protected by the catch
|
||
|
|
(abs 1 2))
|
||
|
|
(lambda args ; the error handler
|
||
|
|
(apply format #t (cadr args))))
|
||
|
|
<em class="gray">"abs: too many arguments: (1 2)"</em>
|
||
|
|
> (<em class="red">catch</em> 'division-by-zero
|
||
|
|
(lambda () (/ 1.0 0.0))
|
||
|
|
(lambda args (string->number "+inf.0")))
|
||
|
|
<em class="gray">+inf.0</em>
|
||
|
|
|
||
|
|
(define-macro (catch-all . body)
|
||
|
|
`(<em class="red">catch</em> #t (lambda () ,@body) (lambda args args)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
catch has 3 arguments: a tag indicating what error to catch (#t = anything),
|
||
|
|
the code, a thunk, that the catch is protecting, and the function to call
|
||
|
|
if a matching error occurs during the evaluation of the thunk. The error handler
|
||
|
|
takes a rest argument which will hold whatever the error function chooses to pass it.
|
||
|
|
The error function itself takes at least 2 arguments, the error type, a symbol,
|
||
|
|
and the error message. There may also be other arguments describing the error.
|
||
|
|
The default action, in the absence of any catch, is to treat the message as
|
||
|
|
a format control string, apply format to it and the other arguments, and
|
||
|
|
send that info to the current-error-port:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(catch #t
|
||
|
|
(lambda ()
|
||
|
|
(error 'oops))
|
||
|
|
(lambda args
|
||
|
|
(format (current-error-port) "~A: ~A~%~A[~A]:~%~A~%"
|
||
|
|
(car args) ; the error type
|
||
|
|
(apply format #f (cadr args)) ; the error info
|
||
|
|
(port-filename) (port-line-number); error file location
|
||
|
|
(stacktrace)))) ; and a stacktrace
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<p>Normally when reading a file, we have to check for #<eof>, but we can let s7
|
||
|
|
do that:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre>(define (copy-file infile outfile)
|
||
|
|
(call-with-input-file infile
|
||
|
|
(lambda (in)
|
||
|
|
(call-with-output-file outfile
|
||
|
|
(lambda (out)
|
||
|
|
(<em class="red">catch</em> 'wrong-type-arg ; s7 raises this error if write-char gets #<eof>
|
||
|
|
(lambda ()
|
||
|
|
(do () () ; read/write until #<eof>
|
||
|
|
(write-char (read-char in) out)))
|
||
|
|
(lambda err
|
||
|
|
outfile)))))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>catch is not limited to error handling:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define (map-with-exit func . args)
|
||
|
|
;; map, but if early exit taken, return the accumulated partial result
|
||
|
|
;; func takes escape thunk, then args
|
||
|
|
(let* ((result ())
|
||
|
|
(escape-tag (gensym))
|
||
|
|
(escape (lambda () (throw escape-tag))))
|
||
|
|
(<em class="red">catch</em> escape-tag
|
||
|
|
(lambda ()
|
||
|
|
(let ((len (apply max (map length args))))
|
||
|
|
(do ((ctr 0 (+ ctr 1)))
|
||
|
|
((= ctr len) (reverse result)) ; return the full result if no throw
|
||
|
|
(let ((val (apply func escape (map (lambda (x) (x ctr)) args))))
|
||
|
|
(set! result (cons val result))))))
|
||
|
|
(lambda args
|
||
|
|
(reverse result))))) ; if we catch escape-tag, return the partial result
|
||
|
|
|
||
|
|
(define (truncate-if func lst)
|
||
|
|
(map-with-exit (lambda (escape x) (if (func x) (escape) x)) lst))
|
||
|
|
|
||
|
|
> (truncate-if even? #(1 3 5 -1 4 6 7 8))
|
||
|
|
<em class="gray">(1 3 5 -1)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>But this is less useful than map (it can't map over a hash-table for example),
|
||
|
|
and is mostly reimplementing built-in code. Perhaps s7 should have an extension
|
||
|
|
of map (and more usefully, for-each) that is patterned after dynamic-wind:
|
||
|
|
<code>(dynamic-for-each init-func main-func end-func . args)</code> where init-func
|
||
|
|
is called with one argument, the length of the shortest sequence argument (for-each
|
||
|
|
and map know this in advance); main-func takes n arguments where n matches
|
||
|
|
the number of sequences passed; and end-func is called even if a jump out of main-func
|
||
|
|
occurs (like dynamic-wind in this regard). In the dynamic-map case, the end-func
|
||
|
|
takes one argument, the current, possibly partial, result list. dynamic-for-each
|
||
|
|
then could easily (but maybe not efficiently) implement generic functions such as ->list, ->vector, and
|
||
|
|
->string (converting any sequence into a sequence of some other type).
|
||
|
|
map-with-exit would be
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (map-with-exit func . args)
|
||
|
|
(let ((result ()))
|
||
|
|
(call-with-exit
|
||
|
|
(lambda (quit)
|
||
|
|
(apply dynamic-map #f ; no init-func in this case
|
||
|
|
(lambda main-args
|
||
|
|
(apply func quit main-args))
|
||
|
|
(lambda (res)
|
||
|
|
(set! result res))
|
||
|
|
args)))
|
||
|
|
result))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>With all the lambda boilerplate, nested catches are hard to read:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(catch #t
|
||
|
|
(lambda ()
|
||
|
|
(catch 'division-by-zero
|
||
|
|
(lambda ()
|
||
|
|
(catch 'wrong-type-arg
|
||
|
|
(lambda ()
|
||
|
|
(abs -1))
|
||
|
|
(lambda args (format () "got a bad arg~%") -1)))
|
||
|
|
(lambda args 0)))
|
||
|
|
(lambda args 123))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Perhaps we need a macro:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define-macro (catch-case clauses . body)
|
||
|
|
(let ((base (cons 'lambda (cons () body))))
|
||
|
|
(for-each (lambda (clause)
|
||
|
|
(let ((tag (car clause)))
|
||
|
|
(set! base `(lambda ()
|
||
|
|
(catch ',(or (eq? tag 'else) tag)
|
||
|
|
,base
|
||
|
|
,@(cdr clause))))))
|
||
|
|
clauses)
|
||
|
|
(caddr base)))
|
||
|
|
|
||
|
|
;;; the code above becomes:
|
||
|
|
(catch-case ((wrong-type-arg (lambda args (format () "got a bad arg~%") -1))
|
||
|
|
(division-by-zero (lambda args 0))
|
||
|
|
(else (lambda args 123)))
|
||
|
|
(abs -1))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>This is similar to r7rs scheme's "guard", but I don't want a pointless thunk for the body of the catch.
|
||
|
|
Along the same lines:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (catch-if test func err)
|
||
|
|
(catch #t
|
||
|
|
func
|
||
|
|
(lambda args
|
||
|
|
(apply (if (test (car args)) err throw) args)))) ; if not caught, re-raise the error via throw
|
||
|
|
|
||
|
|
(define (catch-member lst func err)
|
||
|
|
(catch-if (lambda (tag) (member tag lst)) func err))
|
||
|
|
|
||
|
|
(define-macro (catch* clauses . error)
|
||
|
|
;; try each clause until one evaluates without error, else error:
|
||
|
|
;; (macroexpand (catch* ((+ 1 2) (- 3 4)) 'error))
|
||
|
|
;; (catch #t (lambda () (+ 1 2)) (lambda args (catch #t (lambda () (- 3 4)) (lambda args 'error))))
|
||
|
|
(define (builder lst)
|
||
|
|
(if (null? lst)
|
||
|
|
(apply values error)
|
||
|
|
`(catch #t (lambda () ,(car lst)) (lambda args ,(builder (cdr lst))))))
|
||
|
|
(builder clauses))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<!--
|
||
|
|
(define (or-catch . funks)
|
||
|
|
(call-with-exit
|
||
|
|
(lambda (return)
|
||
|
|
(for-each
|
||
|
|
(lambda (f)
|
||
|
|
(catch #t
|
||
|
|
(lambda ()
|
||
|
|
(return (f)))
|
||
|
|
(lambda args
|
||
|
|
(case (car args)
|
||
|
|
((wrong-type-arg) ...)
|
||
|
|
(...)
|
||
|
|
(else (apply throw args))))))
|
||
|
|
funks))))
|
||
|
|
-->
|
||
|
|
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
<p>When an error is encountered, and when s7 is interrupted via <a href="#beginhook">begin_hook</a>,
|
||
|
|
(<em class="def" id="owlet">owlet</em>) returns an environment that contains
|
||
|
|
additional info about that error:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<ul>
|
||
|
|
<li>error-type: the error type or tag, e.g. 'division-by-zero
|
||
|
|
</li><li>error-data: the message or information passed by the error function
|
||
|
|
</li><li>error-code: the code that s7 thinks triggered the error
|
||
|
|
</li><li>error-line: the line number of that code
|
||
|
|
</li><li>error-file: the file name of that code
|
||
|
|
</li><li>error-history: previous evaluations leading to the error (a circular list)
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
<p>The error-history field depends on the compiler flag WITH_HISTORY. See ow! in
|
||
|
|
stuff.scm for one way to display this data. The *s7* field 'history-size sets the size of the buffer.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>To find a variable's value at the point of the error: <code>((owlet) var)</code>.
|
||
|
|
To list all the local bindings from the error outward:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(do ((e (outlet (owlet)) (outlet e)))
|
||
|
|
((eq? e (rootlet)))
|
||
|
|
(format () "~{~A ~}~%" e))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>To see the current s7 stack, <code>(stacktrace)</code>. You'll probably
|
||
|
|
want to use this in conjunction with *error-hook*.
|
||
|
|
To evaluate the error handler in the environment of the error:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(let ((x 1))
|
||
|
|
(catch #t
|
||
|
|
(lambda ()
|
||
|
|
(let ((y 2))
|
||
|
|
(error 'oops)))
|
||
|
|
(lambda args
|
||
|
|
(with-let (sublet (owlet) :args args) ; add the error handler args
|
||
|
|
(list args x y))))) ; we have access to 'y'
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>To limit the maximum size of the stack, set (*s7* 'max-stack-size).
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
<p>The hook <em class="def" id="errorhook">*error-hook*</em> provides a way to specialize error reporting.
|
||
|
|
Its arguments are named 'type and 'data.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(set! (hook-functions *error-hook*)
|
||
|
|
(list (lambda (hook)
|
||
|
|
(apply format *stderr* (hook 'data))
|
||
|
|
(newline *stderr*))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p><em class="def" id="readerrorhook">*read-error-hook*</em> provides two hooks into the reader.
|
||
|
|
A major problem when reading code written for other Schemes is that each Scheme provides
|
||
|
|
a plethora of idiosyncratic #-names (even special character names), and \ escapes in string
|
||
|
|
constants. *read-error-hook* provides a way to handle these weird cases. If a #-name
|
||
|
|
is encountered that s7 can't deal with, *read-error-hook* is called with two arguments,
|
||
|
|
#t and the string representing the constant. If you set (hook 'result), that result is
|
||
|
|
returned to the reader. Otherwise a 'read-error is raised and you drop into the error handler.
|
||
|
|
Similarly, if some bizaare \ use occurs, *read-error-hook* is called with two arguments,
|
||
|
|
#f and the offending character. If you return a character, it is passed to the reader;
|
||
|
|
otherwise you get an error. lint.scm has an example.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p><em class="def" id="rootletredefinitionhook">*rootlet-redefinition-hook*</em> is called when
|
||
|
|
a top-level variable is redefined (via define and friends, not set!).
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(set! (hook-functions *rootlet-redefinition-hook*)
|
||
|
|
(list (lambda (hook)
|
||
|
|
(format *stderr* "~A ~A~%" (hook 'name) (hook 'value)))))
|
||
|
|
</pre>
|
||
|
|
<p>will print out the variable's name and the new value.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>The s7-built-in catch tags are 'wrong-type-arg, 'syntax-error, 'read-error, 'unbound-variable,
|
||
|
|
'out-of-memory, 'wrong-number-of-args, 'format-error, 'out-of-range, 'division-by-zero, 'io-error, and 'bignum-error.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="autoload"><h4>autoload</h4></div>
|
||
|
|
|
||
|
|
<!-- INDEX autoload:autoload -->
|
||
|
|
<p>
|
||
|
|
If s7 encounters an unbound variable, it first looks to see if it has any autoload information about it.
|
||
|
|
This info can be declared via <em class="def">autoload</em>, a function of two arguments, the
|
||
|
|
symbol that triggers the autoload, and either a filename or a function. If a filename, s7
|
||
|
|
loads that file; if a function, it is called with one argument, the current (calling) environment.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(autoload 'channel-distance "dsp.scm")
|
||
|
|
;; now if we subsequently call channel-distance but forget to load "dsp.scm" first,
|
||
|
|
;; s7 loads "dsp.scm" itself, and uses its definition of channel-distance.
|
||
|
|
;; The C-side equivalent is s7_autoload.
|
||
|
|
|
||
|
|
;; here is the cload.scm case, loading j0 from the math library if it is called:
|
||
|
|
(autoload 'j0
|
||
|
|
(lambda (e)
|
||
|
|
(unless (provided? 'cload.scm)
|
||
|
|
(load "cload.scm"))
|
||
|
|
(c-define '(double j0 (double)) "" "math.h")
|
||
|
|
(varlet e 'j0 j0)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The entity (hash-table or environment probably) that holds the autoload info is named *autoload*.
|
||
|
|
If after checking autoload, the symbol is still unbound, s7 calls
|
||
|
|
<em class="def" id="unboundvariablehook">*unbound-variable-hook*</em>.
|
||
|
|
The offending symbol is named 'variable in the hook environment.
|
||
|
|
If after running *unbound-variable-hook*, the symbol is still unbound,
|
||
|
|
s7 calls the error handler.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>The autoloader knows about s7 environments used as libraries, so, for example,
|
||
|
|
you can <code>(autoload 'j0 "libm.scm")</code>, then use j0 in scheme code. The first
|
||
|
|
time s7 encounters j0, j0 is undefined, so
|
||
|
|
s7 loads libm.scm. That load returns the C math library as the environment *libm*.
|
||
|
|
s7 then automatically looks for j0 in *libm*, and defines it for you.
|
||
|
|
So the result is the same as if you had defined j0 yourself in C code.
|
||
|
|
You can use the r7rs library mechanism here, or with-let, or
|
||
|
|
whatever you want! (In Snd, libc, libm, libdl, and libgdbm are automatically
|
||
|
|
tied into s7 via autoload, so if you call, for example, frexp, libm.scm
|
||
|
|
is loaded, and frexp is exported from the *libm* environment, then the
|
||
|
|
evaluator soldiers on, as if frexp had always been defined in s7).
|
||
|
|
You can also import all of (say) gsl into the current environment
|
||
|
|
via <code>(varlet (curlet) *libgsl*)</code>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="constants"><h4>define-constant</h4></div>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b><em class="def" id="defineconstant">define-constant</em></b> defines a symbol whose value is always the same (within the current lexical scope),
|
||
|
|
<b><em class="def" id="constantp">constant?</em></b> returns #t if its argument is a constant,
|
||
|
|
<b><em class="def" id="immutableb">immutable!</em></b> declares a sequence to be immutable (its elements can't be changed), and
|
||
|
|
<b><em class="def" id="immutablep">immutable?</em></b> returns #t if its argument is immutable.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define v (immutable! (vector 1 2 3)))
|
||
|
|
<em class="gray">#(1 2 3)</em>
|
||
|
|
> (vector-set! v 0 23)
|
||
|
|
<em class="red">error</em><em class="gray">: can't vector-set! #(1 2 3) (it is immutable)</em>
|
||
|
|
> (immutable? v)
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
|
||
|
|
> (define-constant var 32)
|
||
|
|
<em class="gray">var</em>
|
||
|
|
> (set! var 1)
|
||
|
|
<em class="gray">;set!: can't alter immutable object: var</em>
|
||
|
|
> (let ((var 1)) var)
|
||
|
|
<em class="gray">;can't bind or set an immutable object: var, line 1</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>There is one complication here. <code>(immutable! let)</code> closes the let in the sense
|
||
|
|
that you can't add locals to or delete locals from the let. You can still set! the locals. To make
|
||
|
|
the locals themselves immutable:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (vars-immutable! L)
|
||
|
|
(with-let L
|
||
|
|
(for-each (lambda (f)
|
||
|
|
(immutable! (car f)))
|
||
|
|
(curlet)))
|
||
|
|
L)
|
||
|
|
</pre>
|
||
|
|
<p>Now <code>(vars-immutable! let)</code> makes it an error to set! any of the locals, but you
|
||
|
|
can add locals to the let.
|
||
|
|
You can speed up evaluation by doing this because it tells the optimizer that the current entries in the let will not change.
|
||
|
|
To completely petrify the let, <code>(immutable! (vars-immutable! let))</code>.
|
||
|
|
To make a function's documentation immutable: <code>(with-let (funclet 'f2) (immutable! '+documentation+))</code>,
|
||
|
|
and similarly for other function closure entries.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<p>define-constant blocks any attempt to set! or shadow the constant (lexically speaking of course),
|
||
|
|
so local constants behave as you'd expect:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let () (define-constant x 3) (let ((x 32)) x))
|
||
|
|
<em class="red">error</em><em class="gray">: can't bind an immutable object: ((x 32))</em>
|
||
|
|
> (let ((x 3)) (set! x (let () (define-constant x 32) x))) ; outer x is not a constant
|
||
|
|
32
|
||
|
|
</pre>
|
||
|
|
<p>But watch out for deferred bindings:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define (func a) (let ((cvar (+ a 1))) cvar))
|
||
|
|
<em class="gray">func</em>
|
||
|
|
> (define-constant cvar 23) ; cvar is now globally constant so it can't be shadowed
|
||
|
|
<em class="gray">23</em>
|
||
|
|
> (func 1) ; here we're trying to shadow cvar
|
||
|
|
<em class="red">error</em><em class="gray">: can't bind an immutable object: ((cvar (+ a 1)))</em>
|
||
|
|
> (let ((x 1))
|
||
|
|
(define z (let ()
|
||
|
|
(define-constant x 3)
|
||
|
|
(lambda (y)
|
||
|
|
(let ((x y)) ; this x is the inner constant x
|
||
|
|
x))))
|
||
|
|
(z 1)) ; so this is an error even though the outer x is not a constant
|
||
|
|
<em class="red">error</em><em class="gray">: can't bind an immutable object: ((x y))</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
A function can also be a constant. In some cases, the optimizer can take advantage
|
||
|
|
of this information to speed up function calls.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Constants are very similar to things such as keywords (no set, always return itself as its value),
|
||
|
|
variable trace (informative function upon set or keeping a history of past values), typed variables (restricting a
|
||
|
|
variable's values or doing automatic conversions upon set), and notification upon set (either in Scheme
|
||
|
|
or in C; I wanted this many years ago in Snd). The notification function is especially useful if
|
||
|
|
you have a Scheme variable and want to reflect any change in its value immediately in C (see <a href="#notify">below</a>).
|
||
|
|
In s7, setter sets this function.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Each environment is a set of symbols and their associated values.
|
||
|
|
setter places a function (or macro) between a symbol
|
||
|
|
and its value in a given environment. The setter function takes two
|
||
|
|
arguments, the symbol and the new value, and
|
||
|
|
returns the value that is actually set. If the setter function accepts a
|
||
|
|
third argument, the current (symbol-relative) environment
|
||
|
|
is also passed (the weird argument order is an historical artifact).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define e ; save environment for use below
|
||
|
|
(let ((x 3) ; will always be an integer
|
||
|
|
(y 3) ; will always keep its initial value
|
||
|
|
(z 3)) ; will report set!
|
||
|
|
|
||
|
|
(set! (setter 'x) (lambda (s v) (if (integer? v) v x)))
|
||
|
|
(set! (setter 'y) (lambda (s v) y))
|
||
|
|
(set! (setter 'z) (lambda (s v) (format *stderr* "z ~A -> ~A~%" z v) v))
|
||
|
|
|
||
|
|
(set! x 3.3) ; x does not change because 3.3 is not an integer
|
||
|
|
(set! y 3.3) ; y does not change
|
||
|
|
(set! z 3.3) ; prints "z 3 -> 3.3"
|
||
|
|
(curlet)))
|
||
|
|
|
||
|
|
> e
|
||
|
|
<em class="gray">(inlet 'x 3 'y 3 'z 3.3)</em>
|
||
|
|
>(begin (set! (e 'x) 123) (set! (e 'y) #()) (set! (e 'z) #f))
|
||
|
|
;; prints "z 3.3 -> #f"
|
||
|
|
> e
|
||
|
|
<em class="gray">(inlet 'x 123 'y 3 'z #f)</em>
|
||
|
|
> (define-macro (reflective-let vars . body)
|
||
|
|
`(let ,vars
|
||
|
|
,@(map (lambda (vr)
|
||
|
|
`(set! (setter ',(car vr))
|
||
|
|
(lambda (s v)
|
||
|
|
(format *stderr* "~S -> ~S~%" s v)
|
||
|
|
v)))
|
||
|
|
vars)
|
||
|
|
,@body))
|
||
|
|
<em class="gray">reflective-let</em>
|
||
|
|
> (reflective-let ((a 1)) (set! a 2))
|
||
|
|
<em class="gray">2</em> ; prints "a -> 2"
|
||
|
|
>(let ((a 0))
|
||
|
|
(set! (setter 'a)
|
||
|
|
(let ((history (make-vector 3 0))
|
||
|
|
(position 0))
|
||
|
|
(lambda (s v)
|
||
|
|
(set! (history position) v)
|
||
|
|
(set! position (+ position 1))
|
||
|
|
(if (= position 3) (set! position 0))
|
||
|
|
v)))
|
||
|
|
(set! a 1)
|
||
|
|
(set! a 2)
|
||
|
|
((funclet (setter 'a)) 'history))
|
||
|
|
<em class="gray">#(1 2 0)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>See also typed-let in stuff.scm.
|
||
|
|
define-constant is more restrictive than a setter that raises an error: the latter
|
||
|
|
does not block nested (possibly non-constant) bindings of the symbol. The setters
|
||
|
|
are kind of ugly. Here's a macro that lets you put the let variable's setter after
|
||
|
|
the initial value:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define-macro (let/setter vars . body)
|
||
|
|
;; (let/setter ((name value [setter])...) ...)
|
||
|
|
(let ((setters (map (lambda (binding)
|
||
|
|
(and (pair? (cddr binding))
|
||
|
|
(caddr binding)))
|
||
|
|
vars))
|
||
|
|
(gsetters (gensym)))
|
||
|
|
`(let ((,gsetters (list ,@setters))
|
||
|
|
,@(map (lambda (binding)
|
||
|
|
(list (car binding) (cadr binding)))
|
||
|
|
vars))
|
||
|
|
,@(do ((s setters (cdr s))
|
||
|
|
(var vars (cdr var))
|
||
|
|
(i 0 (+ i 1))
|
||
|
|
(result ()))
|
||
|
|
((null? s)
|
||
|
|
(reverse result))
|
||
|
|
(if (car s)
|
||
|
|
(set! result (cons `(set! (setter (quote ,(caar var))) (list-ref ,gsetters ,i)) result))))
|
||
|
|
,@body)))
|
||
|
|
|
||
|
|
(let ((a 3))
|
||
|
|
(let/setter ((a 1)
|
||
|
|
(b 2 (lambda (s v)
|
||
|
|
(+ v a)))) ; this is the outer "a"
|
||
|
|
(set! a (+ a 1))
|
||
|
|
(set! b (+ a b))
|
||
|
|
(display (list a b)) (newline)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="miscellanea"><h4>marvels and curiousities</h4></div>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b><em class="def" id="loadpath">*load-path*</em></b> is a list of directories to search when loading a file.
|
||
|
|
<b><em class="def" id="loadhook">*load-hook*</em></b> is a hook whose functions are called just before a file is loaded.
|
||
|
|
The hook function argument, named 'name, is the filename.
|
||
|
|
While loading, port-filename and
|
||
|
|
port-line-number of the current-input-port can tell you
|
||
|
|
where you are in the file. This data is also available after loading via <em class="def" id="pairlinenumber">pair-line-number</em>
|
||
|
|
and <em class="def" id="pairfilename">pair-filename</em>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(set! (hook-functions *load-hook*)
|
||
|
|
(list (lambda (hook)
|
||
|
|
(format () "loading ~S...~%" (hook 'name)))))
|
||
|
|
|
||
|
|
(set! (hook-functions *load-hook*)
|
||
|
|
(cons (lambda (hook)
|
||
|
|
(format *stderr* "~A~%"
|
||
|
|
(system (string-append "./snd lint.scm -e '(begin (lint \"" (hook 'name) "\") (exit))'") #t)))
|
||
|
|
(hook-functions *load-hook*)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Here's a *load-hook* function that adds the loaded file's directory
|
||
|
|
to the *load-path* variable so that subsequent loads don't need to specify
|
||
|
|
the directory:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(set! (hook-functions <em class="red">*load-hook*</em>)
|
||
|
|
(list (lambda (hook)
|
||
|
|
(let ((pos -1)
|
||
|
|
(filename (hook 'name)))
|
||
|
|
(do ((len (length filename))
|
||
|
|
(i 0 (+ i 1)))
|
||
|
|
((= i len))
|
||
|
|
(if (char=? (filename i) #\/)
|
||
|
|
(set! pos i)))
|
||
|
|
(if (positive? pos)
|
||
|
|
(let ((directory-name (substring filename 0 pos)))
|
||
|
|
(if (not (member directory-name <em class="red">*load-path*</em>))
|
||
|
|
(set! <em class="red">*load-path*</em> (cons directory-name *load-path*)))))))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<p>As in Common Lisp, <b><em class="def" id="featureslist">*features*</em></b> is a list describing what is currently loaded into s7. You can
|
||
|
|
check it with the <b>provided?</b> function, or add something to it with <b>provide</b>. In my version of Snd,
|
||
|
|
at startup *features* is:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> *features*
|
||
|
|
<em class="gray">(snd-20.0 snd20 snd audio snd-s7 snd-motif gsl alsa xm clm6 clm sndlib linux
|
||
|
|
autoload dlopen history complex-numbers system-extras overflow-checks ratio s7-8.11 s7)</em>
|
||
|
|
> (provided? 'gsl)
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The other side of <code>provide</code> is <em class="def" id="requires7">require</em>.
|
||
|
|
<code>(require . things)</code> finds each thing
|
||
|
|
(via <a href="#autoload">autoload</a>), and if that thing has not already been loaded,
|
||
|
|
loads the associated file. <code>(require integrate-envelope)</code>
|
||
|
|
loads "env.scm", for example; in this case it is equivalent to
|
||
|
|
simply using integrate-envelope, but if placed at the start of
|
||
|
|
a file, it documents that you're using that function.
|
||
|
|
In the more normal use, <code>(require snd-ws.scm)</code>
|
||
|
|
looks for the file that has <code>(provide 'snd-ws.scm)</code>
|
||
|
|
and if it hasn't already been loaded, loads it ("ws.scm" in this case).
|
||
|
|
To add your own files to this mechanism, add the provided symbol via <a href="#autoload">autoload</a>.
|
||
|
|
Since load can take an environment argument, *features* and its friends follow block structure.
|
||
|
|
So, for example, (let () (require stuff.scm) ...) loads "stuff.scm" into the local environment,
|
||
|
|
not globally.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>*features* is an odd variable: it is spread out across the chain of environments, and
|
||
|
|
can hold features in an intermediate environment that aren't in subsequent (nested) values.
|
||
|
|
One simple way this can happen is to load a file in a let, but cause the load to happen
|
||
|
|
at the top level. The provided entities get added to the top-level *features* value,
|
||
|
|
not the current let's value, but they are actually accessible locally. So *features*
|
||
|
|
is a merge of all its currently accessible values, vaguely like call-next-method in
|
||
|
|
CLOS. We can mimic this behavior:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(let ((x '(a)))
|
||
|
|
(let ((x '(b)))
|
||
|
|
(define (transparent-memq sym var e)
|
||
|
|
(let ((val (symbol->value var e)))
|
||
|
|
(or (and (pair? val)
|
||
|
|
(memq sym val))
|
||
|
|
(and (not (eq? e (rootlet)))
|
||
|
|
(transparent-memq sym var (outlet e))))))
|
||
|
|
(let ((ce (curlet)))
|
||
|
|
(list (transparent-memq 'a 'x ce)
|
||
|
|
(transparent-memq 'b 'x ce)
|
||
|
|
(transparent-memq 'c 'x ce)))))
|
||
|
|
|
||
|
|
'((a) (b) #f)
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<!--
|
||
|
|
(let ((spread-function (lambda (x e) (+ x 1))))
|
||
|
|
(let ((spread-function (lambda (x e) (+ x 2))))
|
||
|
|
(let ((x 3))
|
||
|
|
(define (spread-function x e)
|
||
|
|
(let ((val x))
|
||
|
|
(do ((e1 e (outlet e1)))
|
||
|
|
((eq? e1 (rootlet)) val)
|
||
|
|
(let ((f (symbol->value 'spread-function e1)))
|
||
|
|
(if (procedure? f)
|
||
|
|
(set! val (f val (rootlet))))))))
|
||
|
|
(spread-function x (curlet)))))
|
||
|
|
6
|
||
|
|
-->
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<p>Multi-line and in-line comments can be enclosed in #| and |#.
|
||
|
|
<code>(+ #| add |# 1 2)</code>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p>Leaving aside this case and the booleans, #f and #t, you can specify your own handlers for
|
||
|
|
tokens that start with "#". <b><em class="def" id="sharpreaders">*#readers*</em></b> is a list of pairs: <code>(char . func)</code>.
|
||
|
|
"char" refers to the first character after the sharp sign (#). "func" is a function of
|
||
|
|
one argument, the string that follows the #-sign up to the next delimiter. "func" is called
|
||
|
|
when #<char> is encountered. If it returns something other than #f, the #-expression
|
||
|
|
is replaced with that value. Scheme has several predefined #-readers for cases such
|
||
|
|
as #b1, #\a, and so on, but you can override these if you like. If the string
|
||
|
|
passed in is not the complete #-expression, the function can use read-char or read to get the
|
||
|
|
rest. Say we'd like #t<number> to interpret the number in base 12:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(set! *#readers* (cons (cons #\t (lambda (str) (string->number (substring str 1) 12))) *#readers*))
|
||
|
|
|
||
|
|
> #tb
|
||
|
|
<em class="gray">11</em>
|
||
|
|
> #t11.3
|
||
|
|
<em class="gray">13.25</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Or have #c(real imag) be read as a complex number:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(set! *#readers* (cons (cons #\c (lambda (str) (apply complex (read)))) *#readers*))
|
||
|
|
|
||
|
|
> #c(1 2)
|
||
|
|
<em class="gray">1+2i</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Here's a reader macro for read-time evaluation:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(set! *#readers*
|
||
|
|
(cons (cons #\. (lambda (str)
|
||
|
|
(and (string=? str ".") (eval (read)))))
|
||
|
|
*#readers*))
|
||
|
|
|
||
|
|
> '(1 2 #.(* 3 4) 5)
|
||
|
|
<em class="gray">(1 2 12 5)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<p>And a reader that implements #[...]# for literal hash-tables:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (set! *#readers*
|
||
|
|
(list (cons #\[ (lambda (str)
|
||
|
|
(let ((h (make-hash-table)))
|
||
|
|
(do ((c (read) (read)))
|
||
|
|
((eq? c ']#) h) ; ]# is a symbol from the reader's point of view
|
||
|
|
(set! (h (car c)) (cdr c))))))))
|
||
|
|
<em class="gray">((#\[ . #<lambda (str)>))</em>
|
||
|
|
> #[(a . 1) (b . #[(c . 3)]#)]#
|
||
|
|
<em class="gray">(hash-table '(b . (hash-table '(c . 3))) '(a . 1))</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<p>To return no value from a reader, use <code>(values)</code>.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (set! *#readers* (cons (cons #\; (lambda (str) (if (string=? str ";") (read)) (values))) *#readers*))
|
||
|
|
<em class="gray">((#\; . #<lambda (str)>))</em>
|
||
|
|
> (+ 1 #;(* 2 3) 4)
|
||
|
|
<em class="gray">5</em>
|
||
|
|
</pre>
|
||
|
|
<p>Here is CL's #+ reader:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (sharp-plus str)
|
||
|
|
;; str here is "+", we assume either a symbol or an expression involving symbols follows
|
||
|
|
(let ((e (if (string=? str "+")
|
||
|
|
(read) ; must be #+(...)
|
||
|
|
(string->symbol (substring str 1)))) ; #+feature
|
||
|
|
(expr (read))) ; this is the expression following #+
|
||
|
|
(if (symbol? e)
|
||
|
|
(if (provided? e)
|
||
|
|
expr
|
||
|
|
(values))
|
||
|
|
(if (not (pair? e))
|
||
|
|
(error 'wrong-type-arg "strange #+ chooser: ~S~%" e)
|
||
|
|
(begin ; evaluate the #+(...) expression as in cond-expand
|
||
|
|
(define (traverse tree)
|
||
|
|
(if (pair? tree)
|
||
|
|
(cons (traverse (car tree))
|
||
|
|
(case (cdr tree) ((())) (else => traverse)))
|
||
|
|
(if (memq tree '(and or not)) tree
|
||
|
|
(and (symbol? tree) (provided? tree)))))
|
||
|
|
(if (eval (traverse e))
|
||
|
|
expr
|
||
|
|
(values)))))))
|
||
|
|
</pre>
|
||
|
|
<p>See also the <a href="#circularlistreader">#n=</a> reader below.</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<p id="makelist">(<b>make-list</b> length (initial-element #f)) returns a list of 'length' elements defaulting to 'initial-element'.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<pre class="indented">(<em class="def" id="charposition">char-position</em> char-or-string searched-string (start 0))
|
||
|
|
(<em class="def" id="stringposition">string-position</em> substring searched-string (start 0))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b>char-position</b> and <b>string-position</b> search a string for the occurrence of a character,
|
||
|
|
any of a set of characters, or a string. They return either #f if none is found, or the position
|
||
|
|
within the searched string of the first occurrence. The optional third argument sets where the
|
||
|
|
search starts in the second argument.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>If char-position's first argument is a string, it is treated as a set of characters, and
|
||
|
|
char-position looks for the first occurrence of any member of that set.
|
||
|
|
Currently, the strings involved are assumed to be C strings (don't expect embedded nulls
|
||
|
|
to work right in this context).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(call-with-input-file "s7.c" ; report any lines with "static " but no following open paren
|
||
|
|
(lambda (file)
|
||
|
|
(let loop ((line (read-line file #t)))
|
||
|
|
(or (eof-object? line)
|
||
|
|
(let ((pos (<em class="red">string-position</em> "static " line)))
|
||
|
|
(if (and pos
|
||
|
|
(not (<em class="red">char-position</em> #\( (substring line pos))))
|
||
|
|
(if (> (length line) 80)
|
||
|
|
(begin (display (substring line 0 80)) (newline))
|
||
|
|
(display line))))
|
||
|
|
(loop (read-line file #t)))))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<p id="keywords">
|
||
|
|
Keywords exist mainly for define*'s benefit. The keyword functions are:
|
||
|
|
<b>keyword?</b>, <b>string->keyword</b>, <b>symbol->keyword</b>, and <b>keyword->symbol</b>.
|
||
|
|
A keyword is a symbol that starts or ends with a colon. The colon
|
||
|
|
is considered to be a part of the symbol name. A keyword is a constant that evaluates to itself.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<pre class="indented">(<em class="def" id="symboltable">symbol-table</em>)
|
||
|
|
(<em class="def" id="symboltovalue">symbol->value</em> sym (env (curlet)))
|
||
|
|
(<em class="def" id="symboltodynamicvalue">symbol->dynamic-value</em> sym)
|
||
|
|
(<em class="def" id="definedp">defined?</em> sym (env (curlet)) ignore-rootlet)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<code>defined?</code> returns #t if the symbol is defined in the environment:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define-macro (defvar name value)
|
||
|
|
`(unless (defined? ',name)
|
||
|
|
(define ,name ,value)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>If ignore-rootlet is #t, the search is confined to the given environment.
|
||
|
|
</p>
|
||
|
|
<p>
|
||
|
|
<code>symbol->value</code> returns the value (lexically) bound to the symbol, whereas <code>symbol->dynamic-value</code>
|
||
|
|
returns the value dynamically bound to it.
|
||
|
|
</p>
|
||
|
|
<p>
|
||
|
|
<code>symbol-table</code> returns a vector containing the symbols currently in the symbol-table.
|
||
|
|
Here we scan the symbol table looking for any function that doesn't have documentation:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(for-each
|
||
|
|
(lambda (sym)
|
||
|
|
(if (<em class="red">defined?</em> sym)
|
||
|
|
(let ((val (<em class="red">symbol->value</em> sym)))
|
||
|
|
(if (and (procedure? val)
|
||
|
|
(string=? "" (documentation val)))
|
||
|
|
(format *stderr* "~S " sym)))))
|
||
|
|
(<em class="red">symbol-table</em>))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Or get a list of gensyms:</p>
|
||
|
|
<pre>(map (lambda (sym) (if (gensym? sym) sym (values))) (<em class="red">symbol-table</em>))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>An automatic software tester (see also tauto.scm and auto-tester.scm in the tools directory):
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(for-each
|
||
|
|
(lambda (sym)
|
||
|
|
(if (<em class="red">defined?</em> sym)
|
||
|
|
(let ((val (<em class="red">symbol->value</em> sym)))
|
||
|
|
(if (procedure? val)
|
||
|
|
(let ((max-args (cdr (arity val))))
|
||
|
|
(if (or (> max-args 4)
|
||
|
|
(memq sym '(exit abort)))
|
||
|
|
(format () ";skip ~S for now~%" sym)
|
||
|
|
(begin
|
||
|
|
(format () ";whack on ~S...~%" sym)
|
||
|
|
(let ((constants (list #f #t pi () 1 1.5 3/2 1.5+i)))
|
||
|
|
(let autotest ((args ()) (args-left max-args))
|
||
|
|
(catch #t (lambda () (apply func args)) (lambda any #f))
|
||
|
|
(if (> args-left 0)
|
||
|
|
(for-each
|
||
|
|
(lambda (c)
|
||
|
|
(autotest (cons c args) (- args-left 1)))
|
||
|
|
constants)))))))))))
|
||
|
|
(<em class="red">symbol-table</em>))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<p id="s7help"><b>help</b> tries to find information about its argument.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (help 'caadar)
|
||
|
|
<em class="gray">"(caadar lst) returns (car (car (cdr (car lst)))): (caadar '((1 (2 3)))) -> 2"</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<p id="s7gc"><b>gc</b> calls the garbage collector. <code>(gc #f)</code> turns off the GC, and <code>(gc #t)</code> turns it on.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>If you get an error complaining about a "free cell", this is usually a sign that the GC freed some object
|
||
|
|
that it should have left alone. In straight scheme code, it's an s7 bug; please send me mail about it!
|
||
|
|
In foreign code, it probably indicates that you need to protect some s7_pointer with s7_gc_protect.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<pre class="indented">(<b><em class="def" id="equivalentp">equivalent?</em></b> x y)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
Say we want to check that two different computations came to the same result, and that result might
|
||
|
|
involve circular structures. Will equal? be our friend?
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (equal? 2 2.0)
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
> (let ((x +nan.0)) (equal? x x))
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
> (equal? .1 1/10)
|
||
|
|
<em class="gray">#f </em>
|
||
|
|
> (= .1 1/10)
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
> (= 0.0 0+1e-300i)
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>No! We need an equality check that ignores epsilonic differences in real and
|
||
|
|
complex numbers, and knows that NaNs are equal for all practical purposes.
|
||
|
|
Leaving aside numbers,
|
||
|
|
closed ports are not equal, yet nothing can be done with them.
|
||
|
|
#() is not equal to #2d(). And two closures are never equal, even if their
|
||
|
|
arguments, environments, and bodies are equal.
|
||
|
|
Since there might be circles, it is not easy to write
|
||
|
|
a replacement for equal? in Scheme.
|
||
|
|
So, in s7, if one thing is basically the same as
|
||
|
|
some other thing, they satisfy the function equivalent?.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (equivalent? 2 2.0)
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
> (equivalent? 1/0 1/0) ; NaN
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
> (equivalent? .1 1/10)
|
||
|
|
<em class="gray">#t</em> ; floating-point epsilon here is 1.0e-15 or thereabouts
|
||
|
|
> (equivalent? 0.0 1e-300)
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
> (equivalent? 0.0 1e-14)
|
||
|
|
<em class="gray">#f</em> ; its not always #t!
|
||
|
|
> (equivalent? (lambda () #f) (lambda () #f))
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The *s7* field equivalent-float-epsilon sets the floating-point fudge factor.
|
||
|
|
I can't decide how bignums should interact with equivalent?. Currently,
|
||
|
|
if a bignum is involved, either here or in a hash-table, s7 uses equal?.
|
||
|
|
Finally, if either argument is an environment with an 'equivalent? method,
|
||
|
|
that method is invoked.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<b><em class="def" id="expansion">define-expansion</em></b> defines a macro that expands at read-time.
|
||
|
|
It has the same syntax as
|
||
|
|
define-macro, and (in normal use) the same result, but it is much faster because it expands only once.
|
||
|
|
Similarly, <b>define-expansion*</b> defines a read-time macro*.
|
||
|
|
(See also define-with-macros in s7test.scm for a way to expand macros in a function body at definition time).
|
||
|
|
Since the reader knows almost nothing
|
||
|
|
about the code it is reading,
|
||
|
|
you need to make sure the expansion is defined at the top level and that its name is unique.
|
||
|
|
The reader does know about global variables, so:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define *debugging* #t)
|
||
|
|
|
||
|
|
(define-expansion (assert assertion)
|
||
|
|
(if *debugging* ; or maybe better, (eq? (symbol->value '*debugging*) #t)
|
||
|
|
`(unless ,assertion
|
||
|
|
(format *stderr* "~A: ~A failed~%" (*function*) ',assertion))
|
||
|
|
(values)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Now the assertion code is only present in the function body (or wherever)
|
||
|
|
if *debugging* is #t; otherwise assert expands into nothing. Another very handy
|
||
|
|
use is to embed a source file line number into a message; see for example lint-format
|
||
|
|
in lint.scm.
|
||
|
|
Leaving aside
|
||
|
|
read-time expansion and splicing, the real difference between define-macro and define-expansion
|
||
|
|
is that the expansion's result is not evaluated.
|
||
|
|
I'm no historian, but I believe that means that define-expansion creates
|
||
|
|
a (gasp!) f*xpr. In fact:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre>(define-macro (define-f*xpr name-and-args . body)
|
||
|
|
`(define ,(car name-and-args)
|
||
|
|
(apply define-expansion
|
||
|
|
(append (list (append (list (gensym)) ',(cdr name-and-args))) ',body))))
|
||
|
|
|
||
|
|
> (define-f*xpr (mac a) `(+ ,a 1))
|
||
|
|
<em class="gray">mac</em>
|
||
|
|
> (mac (* 2 3))
|
||
|
|
<em class="gray">(+ (* 2 3) 1)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
You can do something similar with a normal macro, or make the indirection explicit:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-macro (fx x) `'(+ 1 ,x)) ; quote result to avoid evaluation
|
||
|
|
<em class="gray">fx</em>
|
||
|
|
> (let ((a 3)) (fx a))
|
||
|
|
<em class="gray">(+ 1 a)</em>
|
||
|
|
> (define-expansion (ex x) `(+ 1 ,x))
|
||
|
|
<em class="gray">ex</em>
|
||
|
|
> (let ((x ex) (a 3)) (x a)) ; avoid read-time splicing
|
||
|
|
<em class="gray">(+ 1 a)</em>
|
||
|
|
> (let ((a 3)) (ex a)) ; spliced in at read-time
|
||
|
|
<em class="gray">4</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>As this example shows, the reader knows nothing about the program context,
|
||
|
|
so if it does not see a list whose first element is a expansion name, it does
|
||
|
|
not do anything special. In the <code>(x a)</code> case above, the
|
||
|
|
expansion happens when the code is evaluated, and the expansion result
|
||
|
|
is simply returned, unevaluated.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>You can also use macroexpand to cancel the evaluation of a macro's expansion:
|
||
|
|
</p>
|
||
|
|
<pre>(define-macro (rmac . args)
|
||
|
|
(if (null? args)
|
||
|
|
()
|
||
|
|
(if (null? (cdr args))
|
||
|
|
`(display ',(car args))
|
||
|
|
(list 'begin
|
||
|
|
`(display ',(car args))
|
||
|
|
(apply macroexpand (list (cons 'rmac (cdr args))))))))
|
||
|
|
|
||
|
|
> (macroexpand (rmac a b c))
|
||
|
|
<em class="gray">(begin (display 'a) (begin (display 'b) (display 'c)))</em>
|
||
|
|
> (begin (rmac a b c d) (newline))
|
||
|
|
<em class="gray">abcd</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The main built-in expansion is <b><em class="def" id="readercond">reader-cond</em></b>. The syntax is based on cond:
|
||
|
|
the car of each clause is evaluated (in the read-time context), and if it is not false,
|
||
|
|
the remainder of that clause is spliced into the code as if you had typed it from the start.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> '(1 2 (reader-cond ((> 1 0) 3) (else 4)) 5 6)
|
||
|
|
<em class="gray">(1 2 3 5 6)</em>
|
||
|
|
> ((reader-cond ((> 1 0) list 1 2) (else cons)) 5 6)
|
||
|
|
<em class="gray">(1 2 5 6)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<!-- from kanren
|
||
|
|
(define-syntax conj*
|
||
|
|
(syntax-rules ()
|
||
|
|
((conj*) succeed)
|
||
|
|
((conj* g) g)
|
||
|
|
((conj* g gs ...)
|
||
|
|
(conj g (lambda (s) ((conj* gs ...) s))))))
|
||
|
|
|
||
|
|
is the same (in that context) as:
|
||
|
|
|
||
|
|
(define-macro (conj* . args)
|
||
|
|
(if (null? args)
|
||
|
|
succeed
|
||
|
|
(if (null? (cdr args))
|
||
|
|
(car args)
|
||
|
|
`(conj ,(car args)
|
||
|
|
(lambda (s) ((conj* ,@(cdr args)) s))))))
|
||
|
|
-->
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
<p id="profiling">
|
||
|
|
Whenever (*s7* 'profile) is positive, profiling is turned on.
|
||
|
|
As the program runs, the profiler collects data about each function it can identify.
|
||
|
|
At any time, you can call show-profile to see that data. The first timing is inclusive
|
||
|
|
(it includes the time spent in any nested calls), the second is exclusive (it is the time
|
||
|
|
spent just in the current function). In Linux and *BSD, we use clock_gettime() which is reasonably
|
||
|
|
fast, but there is some profiler overhead. In other systems, we use clock() which is
|
||
|
|
amazingly slow. The optimizer sometimes recasts tail recursion and similar cases as while loops,
|
||
|
|
so the number of calls listed may be less than you'd expect, but the overall time should be
|
||
|
|
correct. To clear out the current data, call clear-profile.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
<p id="s7env"><b>*s7*</b> is a let that gives access to some of s7's internal
|
||
|
|
state:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">print-length number of elements to print of a non-string sequence
|
||
|
|
max-string-length maximum size arg to make-string and read-string
|
||
|
|
max-format-length maximum size arg to ~N or the width and precision fields for floats in format
|
||
|
|
max-list-length maximum size arg to make-list
|
||
|
|
max-port-data-size maximum size of a port data buffer
|
||
|
|
max-vector-length maximum size arg to make-vector and make-hash-table
|
||
|
|
max-vector-dimensions make-vector dimensions limit
|
||
|
|
default-hash-table-length default size for make-hash-table (8, tables resize as needed)
|
||
|
|
initial-string-port-length 128, initial size of a input string port's buffer
|
||
|
|
output-port-data-size 2048, size of an output port's buffer
|
||
|
|
|
||
|
|
history a circular buffer of recent eval entries stored backwards (use set! to add an entry)
|
||
|
|
history-size eval history buffer size if s7 built WITH_HISTORY=1
|
||
|
|
history-enabled is history buffer receiving additions (if WITH_HISTORY=1 as above)
|
||
|
|
debug determines debugging level (see debug.scm), default=0
|
||
|
|
profile profile switch (0=default, 1=gather profiling info)
|
||
|
|
profile-info the current profiling data; see profile.scm
|
||
|
|
profile-prefix name (a symbol) used to identify the current environment in profile data
|
||
|
|
|
||
|
|
default-rationalize-error 1e-12
|
||
|
|
equivalent-float-epsilon 1e-15
|
||
|
|
hash-table-float-epsilon 1e-12 (currently limited to less than 1e-3).
|
||
|
|
bignum-precision bits for bignum floats (128)
|
||
|
|
float-format-precision digits to print for floats (16)
|
||
|
|
default-random-state the default arg for random
|
||
|
|
most-positive-fixnum if not using gmp, the most positive integer ("fixnum" comes from CL)
|
||
|
|
most-negative-fixnum as above, but negative
|
||
|
|
|
||
|
|
safety 0 (see below)
|
||
|
|
undefined-identifier-warnings #f
|
||
|
|
undefined-constant-warnings #f
|
||
|
|
accept-all-keyword-arguments #f
|
||
|
|
autoloading? #t
|
||
|
|
openlets #t, whether any let can be open globally (this overrides all openlets)
|
||
|
|
expansions? #t, whether expansions are handled at read-time
|
||
|
|
muffle-warnings? #f, if #t s7_warn does not output anything
|
||
|
|
|
||
|
|
cpu-time run time so far
|
||
|
|
file-names currently loaded files (a list)
|
||
|
|
catches a list of the currently active catch tags
|
||
|
|
c-types a list of c-object type names (from s7_make_c_type, etc)
|
||
|
|
|
||
|
|
stack the current stack entries
|
||
|
|
stack-top current stack location
|
||
|
|
stack-size current stack size
|
||
|
|
max-stack-size maximum stack size
|
||
|
|
stacktrace-defaults stacktrace formatting info for error handler
|
||
|
|
|
||
|
|
rootlet-size the number of globals
|
||
|
|
heap-size total cells currently available
|
||
|
|
max-heap-size maximum heap size
|
||
|
|
free-heap-size the number of currently unused cells
|
||
|
|
gc-stats 0 (or #f), 1: show GC activity, 2: heap, 4: stack, 8: protected_objects, #t = 1
|
||
|
|
gc-freed number of cells freed by the last GC pass
|
||
|
|
gc-total-freed number of cells freed so far by the GC; the total allocated is probably close to
|
||
|
|
(with-let *s7* (+ (- heap-size free-heap-size) gc-total-freed))
|
||
|
|
gc-info a list: calls total-time ticks-per-second (see profile.scm)
|
||
|
|
gc-temps-size number of cells just allocated that are protected from the GC (256)
|
||
|
|
gc-resize-heap-fraction when to resize the heap (0.8); these two are aimed at GC experiments
|
||
|
|
gc-resize-heap-by-4-fraction when to get panicky about resizing the heap
|
||
|
|
gc-protected-objects vector of the objects permanently protected from the GC
|
||
|
|
memory-usage a description of current memory allocations (sent to current-output-port)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
Use the standard environment syntax to access these fields:
|
||
|
|
<code>(*s7* 'stack-top)</code>. stuff.scm has the function
|
||
|
|
*s7*->list that returns most of these fields in a list.
|
||
|
|
</p>
|
||
|
|
<p>The compile-time defaults for some of these fields can be set:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">heap-size: INITIAL_HEAP_SIZE (64000)
|
||
|
|
stack-size: INITIAL_STACK_SIZE (4096)
|
||
|
|
gc-temps-size: GC_TEMPS_SIZE (256)
|
||
|
|
bignum-precision: DEFAULT_BIGNUM_PRECISION (128)
|
||
|
|
history-size: DEFAULT_HISTORY_SIZE (8)
|
||
|
|
print-length: DEFAULT_PRINT_LENGTH (12)
|
||
|
|
gc-resize-heap-fraction: GC_RESIZE_HEAP_FRACTION (0.8)
|
||
|
|
output-port-data-size: OUTPUT_PORT_DATA_SIZE (2048)
|
||
|
|
|
||
|
|
See also WITH_WARNINGS, S7_ALIGNED, and GC_TRIGGER_SIZE.
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p><code>(set! (*s7* 'autoloading) #f)</code> turns off the autoloader.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>The 'safety variable is an integer. Currently:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">0: default.
|
||
|
|
1: no remove_from_heap (a GC optimization)
|
||
|
|
infinite loop check in eval, sort! and some iterators
|
||
|
|
immutable object check in reverse!, sort!, and fill!
|
||
|
|
more info in (*s7* 'history) for s7_apply_function, s7_call and s7_eval
|
||
|
|
less aggressive optimization in with-let and lambda
|
||
|
|
warnings about syntax redefinition
|
||
|
|
incoming s7_pointer checks in some FFI functions
|
||
|
|
bignum int to s7_int conversion checks
|
||
|
|
2: vector, string, and pair constants are immutable (but checks for this are currently sparse)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The debug variable controls where <a href="#debug">debug.scm</a> is active. If it is (if debug > 0), it inserts
|
||
|
|
trace calls in functions and so on. It uses <em class="def" id="dynamicunwind">dynamic-unwind</em>
|
||
|
|
to establish a catcher for the return value. <code>(dynamic-unwind function arg)</code> causes
|
||
|
|
<code>function</code> to be called after the traced function has returned, passing it <code>arg</code>
|
||
|
|
and the returned value.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<p><code>(*s7* 'stacktrace-defaults)</code> is a list of four integers and a boolean that tell the error
|
||
|
|
handler how to format stacktrace information. The four integers are:
|
||
|
|
how many frames to display,
|
||
|
|
how many columns are devoted to code display,
|
||
|
|
how many columns are available for a line of data,
|
||
|
|
and where to place comments.
|
||
|
|
The boolean sets whether the entire output should be displayed as a comment.
|
||
|
|
The defaults are '(3 45 80 45 #t).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>This will display s7 memory usage sort of like the top program:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(format *stderr* "~C[~D;~DH" #\escape 0 0)
|
||
|
|
(format *stderr* "~C[J" #\escape)
|
||
|
|
(display (with-output-to-string (lambda() (<em class="red">*s7* 'memory-usage</em>))))
|
||
|
|
</pre>
|
||
|
|
<p>(Ideally we'd only redisplay the changed fields).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>The standard time macro:</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define-macro (time expr)
|
||
|
|
`(let ((start (<em class="red">*s7* 'cpu-time</em>)))
|
||
|
|
(let ((res (list ,expr))) ; expr might return multiple values
|
||
|
|
(list (car res)
|
||
|
|
(- (<em class="red">*s7* 'cpu-time</em>) start)))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Add automatic log10 recalculation to (*s7* 'bignum-precision):</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define log10 (log (bignum 10)))
|
||
|
|
(define bignum-precision (dilambda (lambda ()
|
||
|
|
(<em class="red">*s7* 'bignum-precision</em>))
|
||
|
|
(lambda (val)
|
||
|
|
(set! (<em class="red">*s7* 'bignum-precision</em>) val)
|
||
|
|
(set! log10 (log (bignum 10)))
|
||
|
|
val)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The stack, history and gc-protected-objects fields are intended for debugging. Don't keep
|
||
|
|
these hanging around and expect good things to happen!
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
<pre class="indented">(<em class="def" id="cobject">c-object?</em> obj)
|
||
|
|
(<em class="def" id="cobjecttypew">c-object-type</em> obj)
|
||
|
|
|
||
|
|
(<em class="def" id="cpointer">c-pointer?</em> obj)
|
||
|
|
(<em class="def" id="cpoint">c-pointer</em> int type info weak1 weak2)
|
||
|
|
(<em class="def" id="cpointtype">c-pointer-type</em> obj)
|
||
|
|
(<em class="def" id="cpointinfo">c-pointer-info</em> obj)
|
||
|
|
(<em class="def" id="cpointweak1">c-pointer-weak1</em> obj) ; also weak2
|
||
|
|
(<em class="def" id="cpointertolist">c-pointer->list</em> obj)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
c-object? returns #t is its argument is a c-object.
|
||
|
|
c-object-type returns the object's type tag (otherwise #f of course). This tag is also the position
|
||
|
|
of the object's type in the (*s7* 'c-types) list.
|
||
|
|
(*s7* 'c-types) returns a list of the types created by s7_make_c_type.
|
||
|
|
</p>
|
||
|
|
<p>
|
||
|
|
You can wrap up raw C pointers and
|
||
|
|
pass them around in s7 code. The function c-pointer returns a wrapped pointer,
|
||
|
|
and c-pointer? returns #t if passed one. <code>(define NULL (c-pointer 0))</code>.
|
||
|
|
If the type field is a symbol, it is used to check types in s7_c_pointer with_type.
|
||
|
|
If the 'info field of a c-pointer is a let, that pointer can participate in
|
||
|
|
the generic functions mechanism, much like a c-object:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (let ((ptr (c-pointer 1 'abc
|
||
|
|
(inlet 'object->string
|
||
|
|
(lambda (obj . args)
|
||
|
|
(let ((lt (object->let obj)))
|
||
|
|
(format #f "I am pointer ~A of type '~A!"
|
||
|
|
(lt 'c-pointer) ; we need c-pointer-type etc
|
||
|
|
(lt 'c-type))))))))
|
||
|
|
(openlet ptr)
|
||
|
|
(object->string ptr))
|
||
|
|
<em class="gray">"I am pointer 1 of type 'abc!"</em>
|
||
|
|
</pre>
|
||
|
|
<p>c-pointer->list returns (list pointer-as-int type info).
|
||
|
|
The "weak1" and "weak2" fields are intended for custom "weak" references. The weak
|
||
|
|
fields values are not marked during the GC sweep, much like a key in a weak-hash-table.
|
||
|
|
If either value is GC'd, that field is set to #f by the GC. The weak fields are
|
||
|
|
ignored by equal? and equivalent? when comparing c-pointers, and by object->string
|
||
|
|
of a c-pointer even if :readable is specified.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<p>There are several tree-oriented functions currently built into s7:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(<em class="def" id="treecyclic">tree-cyclic?</em> tree) returns #t if tree contains a cycle.
|
||
|
|
(<em class="def" id="treeleaves">tree-leaves</em> tree) returns the number of leaves in tree.
|
||
|
|
(<em class="def" id="treememq">tree-memq</em> obj tree) returns #t if obj is in tree (using eq?).
|
||
|
|
(<em class="def" id="treesetmemq">tree-set-memq</em> set tree) returns #t if any member of the set (a list of symbols) is in tree.
|
||
|
|
(<em class="def" id="treecount">tree-count</em> obj tree) returns how many times obj is in tree.
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<p>s7 originally had Scheme-level multithreading support, but I removed it in August, 2011.
|
||
|
|
It turned out to be less useful than I hoped,
|
||
|
|
mainly because s7 threads shared the heap and therefore had to coordinate
|
||
|
|
all cell allocations. It was faster and simpler to use multiple
|
||
|
|
processes each running a separate s7 interpreter, rather than one s7
|
||
|
|
running multiple s7 threads. In CLM, there was also contention for access
|
||
|
|
to the output stream. In GUI-related situations,
|
||
|
|
threads were not useful mainly because the GUI toolkits are not thread safe.
|
||
|
|
Last but not least, the effort to make the non-threaded
|
||
|
|
s7 faster messed up parts of the threaded version. Rather than
|
||
|
|
waste a lot of time fixing this, I chose to flush multithreading.
|
||
|
|
s7 is thread-safe:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdio.h>
|
||
|
|
#include <stdlib.h>
|
||
|
|
#include <pthread.h>
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
#define NUM_THREADS 16
|
||
|
|
static pthread_t threads[NUM_THREADS];
|
||
|
|
static pthread_mutex_t lock = PTHREAD_MUTEX_INITIALIZER;
|
||
|
|
|
||
|
|
static void *run_thread(void *obj)
|
||
|
|
{
|
||
|
|
s7_scheme *sc = (s7_scheme *)obj;
|
||
|
|
const char *str;
|
||
|
|
str = s7_object_to_c_string(sc, s7_make_integer(sc, 123));
|
||
|
|
s7_eval_c_string(sc, "(let () \
|
||
|
|
(define (f) \
|
||
|
|
(do ((i 0 (+ i 1))) ((= i 10)) \
|
||
|
|
(do ((k 0 (+ k 1))) ((= k 1000000))) \
|
||
|
|
(format *stderr* \"~D \" i))) \
|
||
|
|
(f))");
|
||
|
|
pthread_mutex_lock(&lock);
|
||
|
|
fprintf(stderr, "%s\n", str);
|
||
|
|
pthread_mutex_unlock(&lock);
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
int32_t i;
|
||
|
|
for (i = 0; i < NUM_THREADS; i++)
|
||
|
|
pthread_create(&threads[i], NULL, run_thread, (void *)s7_init());
|
||
|
|
for (i = 0; i < NUM_THREADS; i++)
|
||
|
|
pthread_join(threads[i], NULL);
|
||
|
|
exit(0);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* linux: gcc -o threads threads.c s7.o -Wl,-export-dynamic -pthread -lm -I. -ldl
|
||
|
|
* mac: clang -o threads threads.c s7.o -pthread -lm -I. -ldl
|
||
|
|
*/
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<p id="s7vsr5rs">Some other differences from r5rs:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<ul style="list-style-type:disc;">
|
||
|
|
<li>no force or delay (see <a href="#r7rs">below</a>).
|
||
|
|
</li><li>no syntax-rules or any of its friends.
|
||
|
|
</li><li>no scheme-report-environment, null-environment, or interaction-environment (use curlet).
|
||
|
|
</li><li>no transcript-on or transcript-off.
|
||
|
|
</li><li>begin returns the value of the last form; it can contain both definitions and other statements.
|
||
|
|
</li><li>#<unspecified>, #<eof>, and #<undefined> are first-class objects.
|
||
|
|
</li><li>for-each and map accept different length arguments; the operation stops when any argument reaches its end.
|
||
|
|
</li><li>for-each and map accept any applicable object as the first argument, and any sequence or iterator as a trailing argument.
|
||
|
|
</li><li>letrec*, but without conviction.
|
||
|
|
</li><li>set! and *-set! return the new value (modulo setter), not #<unspecified>.
|
||
|
|
</li><li>define and its friends return the new value.
|
||
|
|
</li><li>port-closed?
|
||
|
|
</li><li>list? means "pair or null", proper-list? is r5rs list?, float? =
|
||
|
|
real and not rational, sequence? = length, byte? = unsigned byte.
|
||
|
|
<!-- a vector can be a member of itself, and yet vector? returns #t, why is list? different; we even call it a circular list! -->
|
||
|
|
</li><li>the default IO ports are named *stdin*, *stdout*, and *stderr*.
|
||
|
|
</li><li>#f as an output port means nothing is output (#f is /dev/null, I guess).
|
||
|
|
</li><li>member and assoc accept an optional third argument, the comparison function (equal? is the default).
|
||
|
|
</li><li>case accepts => much like cond (the function argument is the selector).
|
||
|
|
</li><li>if WITH_SYSTEM_EXTRAS is 1, the following are built-in:
|
||
|
|
directory?, file-exists?, delete-file, system, directory->list,
|
||
|
|
getenv.
|
||
|
|
</li><li>s7 is case sensitive.
|
||
|
|
</li><li>when and unless (for r7rs), returning the value of the last form.
|
||
|
|
</li><li>the "d", "f", "s", and "l" exponent markers are not supported by default (use "e", "E", or "@").
|
||
|
|
</li><li>quasiquoted vector constants are not supported (use the normal list expansions wrapped in list->vector).
|
||
|
|
</li><li><em class="def" id="typeof">type-of</em> returns a type indicator for its argument.
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
<p>In s7 if a built-in function like gcd is referred to in a function
|
||
|
|
body, the optimizer is free to replace it with #_function. That is, <code>(gcd ...)</code> can be changed
|
||
|
|
to <code>(#_gcd ...)</code> at s7's whim, if gcd has its original value at the time the optimizer
|
||
|
|
sees the expression using it. A subsequent <code>(set! gcd +)</code> does not affect this optimized call.
|
||
|
|
I think I could wave my hands and mumble about "aggressive lexical scope" or something, but actually the
|
||
|
|
choice here is that speed trumps that ol' hobgoblin consistency. If you want to change gcd to +, do it before
|
||
|
|
loading code that calls gcd.
|
||
|
|
I think most Schemes handle macros this way: the macro call is replaced by its expansion using its current
|
||
|
|
definition, and a later redefinition does not affect earlier uses.
|
||
|
|
Guile behaves like s7:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (add1 x) (+ x 1))
|
||
|
|
(set! + -)
|
||
|
|
(display (add1 3))) ; 4 in both s7 and Guile 3.0.4
|
||
|
|
</pre>
|
||
|
|
<p>But if a Scheme function is involved, things get messy:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (fib n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2)))))
|
||
|
|
(define oldfib fib)
|
||
|
|
(set! fib 32)
|
||
|
|
(display (oldfib 10))) ; s7 says 55, Guile says "wrong type to apply: 32"
|
||
|
|
</pre>
|
||
|
|
<p>I can't decide which way is correct: s7 looks more consistent,
|
||
|
|
but:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (fib n) 32)
|
||
|
|
(set! fib (lambda (n) (if (< n 2) n (+ (fib (- n 1)) (fib (- n 2))))))
|
||
|
|
(define oldfib fib)
|
||
|
|
(set! fib 32)
|
||
|
|
(display (oldfib 10)) ; "attempt to apply an integer 32 to..."
|
||
|
|
</pre>
|
||
|
|
<p>So s7 is inconsistent too! (Actually this was consistent until Jan 2021 when I suddenly thought it was
|
||
|
|
a mistake and "fixed" it; now I'm having second thoughts.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<!-- another case: (with-let (inlet '+ -) (+ 2 3)) -> 5 -->
|
||
|
|
<!-- also, (eq? (if #f #f) (apply values ())) is #t, but memq and assq don't treat them as equal -->
|
||
|
|
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Here are some changes I'd make to s7 if I didn't care about compatibility with other Schemes:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<ul style="list-style-type:disc;">
|
||
|
|
<li>remove the exact/inexact distinction including #i and #e (done! #i means int-vector constant).
|
||
|
|
</li><li>remove call-with-values and its friends
|
||
|
|
</li><li>remove char-ready?
|
||
|
|
</li><li>change eof-object? to eof? or just omit it (you can use eq? #<eof>)
|
||
|
|
</li><li>change make-rectangular to complex (done!), and remove make-polar.
|
||
|
|
</li><li>remove unquote (the name, not the functionality).
|
||
|
|
</li><li>remove cond-expand.
|
||
|
|
</li><li>remove *-ci functions
|
||
|
|
</li><li>remove #d (done!)
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
<p>(most of these are removed if you set the compiler flag WITH_PURE_S7), and perhaps:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<ul style="list-style-type:disc;">
|
||
|
|
<li>remove even? and odd?, gcd and lcm.
|
||
|
|
</li><li>remove string-length and vector-length.
|
||
|
|
</li><li>remove list-ref|set!, string-ref|set!, vector-ref|set!,
|
||
|
|
hash-table-ref|set!, set-car!|cdr!, and
|
||
|
|
set-current-output|input|error-port.
|
||
|
|
</li><li>change file-exists? to file? (or omit it and assume the use of libc.scm — why reinvent the wheel?).
|
||
|
|
</li><li>remove all the conversion and copy functions like vector->list and vector-copy (use copy or map).
|
||
|
|
</li><li>change string->symbol to symbol (what to do with symbol->string in that case?)
|
||
|
|
</li><li>change with-output-to-* and with-input-from-* to omit the pointless lambda.
|
||
|
|
</li><li>remove the with-* IO functions (e.g. with-input-from-string), keeping the call-with-* versions (call-with-input-string).
|
||
|
|
</li><li>remove assq, assv, memq, and memv (these are pointless now that assoc and member can be passed eq? and eqv?).
|
||
|
|
</li><li>move all the "*var*" names to *s7*: *load-hook* becomes (*s7* 'load-hook) for example.
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
<p>With the move to s7_setter and s7_set_setter (setter in Scheme),
|
||
|
|
dilambda and dilambda? have been reduced to trivial conveniences, so perhaps they can also be
|
||
|
|
removed.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>string-copy has 3 extra arguments to allow strings to be copied directly into other strings.
|
||
|
|
In vectors, we can use subvector, but substring returns a new string (copying its argument) unless
|
||
|
|
the optimizer notices that the copy is not needed. Copy almost works, but its start and end arguments
|
||
|
|
refer to the source, not the destination. substring should be like subvector, but that is not backwards compatible.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>There are several less-than-ideal names.
|
||
|
|
get-output-string should be current-output-string. write-char behaves
|
||
|
|
like display, not write.
|
||
|
|
provided? should be feature? or *features* should be *provisions*.
|
||
|
|
list-ref, list-set!, and list-tail actually only apply to pairs.
|
||
|
|
let-temporarily should be templet, or maybe set-temporarily.
|
||
|
|
There should not be two names for the same thing: call/cc and
|
||
|
|
call-with-current-continuation: flush the latter!
|
||
|
|
The CL-inspired "log*" names such as logand look very old-fashioned.
|
||
|
|
Standard scheme opts
|
||
|
|
for the name "bitwise*"; why not "integerwise" or "bytevectorwise"? The
|
||
|
|
"wise" business is just noise; are they thinking of The Hobbit?
|
||
|
|
<code>(define & logand) (define | logior) (define ~ lognot)</code>, but ^ for logxor
|
||
|
|
(as in C) is not ideal; ^ should be expt. Finally, I think the notion of a current input or output port is
|
||
|
|
a mistake: the IO functions should always get an explicit port.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
cond-expand is dumb and its name is dumber.
|
||
|
|
Take libgsl.scm; different versions of the GSL library have different functions. We need to know
|
||
|
|
when we're building the FFI what GSL version we're dealing with. It would be nuts to start pushing and checking dozens
|
||
|
|
of library version symbols when all we actually want is <code>(> version 23.19)</code>.
|
||
|
|
In place of cond-expand, s7 uses <a href="#readercond">reader-cond</a>,
|
||
|
|
so the read-time decision involves normal Scheme evaluation.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Then there's the case case: a case clause without a result appears to be an error in r7rs.
|
||
|
|
But the notation used to indicate that is the same as that used for begin,
|
||
|
|
so if we allow <code>(begin)</code>, we should allow case clauses to have no explicit result.
|
||
|
|
In cond,
|
||
|
|
the "implicit progn" (in CL terminology) includes the test expression, so a clause without a result returns
|
||
|
|
the test result (if true of course). In the case case, s7 returns the selector.
|
||
|
|
<code>(case x ((0 1)))</code> is equivalent to <code>(case x ((0 1) => values))</code>,
|
||
|
|
just as <code>(cond (A))</code> is equivalent to <code>(cond (A => values))</code>.
|
||
|
|
One application is method lookup: <code>((case (obj 'abs) ((#<undefined>) abs) (else)) ...)</code>;
|
||
|
|
we would otherwise have to save the lookup result or do it twice.
|
||
|
|
This choice has a ripple
|
||
|
|
effect on do: if no result is specified for do, s7 returns the test result.
|
||
|
|
It also affects
|
||
|
|
hash-tables. Currently hash-table-ref returns #f if the key is not in the table,
|
||
|
|
mimicking assoc and aimed at cond with =>, but if we also use case and #<undefined>,
|
||
|
|
it seems more useful and maybe intuitive to mimic let-ref instead. But if hash-table-ref returns
|
||
|
|
#<undefined>, it's harder to use hash-tables as sets. Hmm.
|
||
|
|
In any case,
|
||
|
|
the fall-through value of case should be (and is in s7)
|
||
|
|
#<unspecified>: case is a form of if, so
|
||
|
|
<code>(if #f #f)</code>, <code>(cond (#f #f))</code>, and <code>(case #t ((#f) #f))</code> should be equal.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<p>
|
||
|
|
Better ideas are always welcome!
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Here are the built-in s7 variables:
|
||
|
|
</p>
|
||
|
|
<ul>
|
||
|
|
<li>*features* ; a list of symbols
|
||
|
|
</li><li>*libraries* ; a list of (filename . let) pairs
|
||
|
|
</li><li>*load-path* ; a list of directories
|
||
|
|
</li><li>*cload-directory* ; directory for cload output
|
||
|
|
</li><li>*autoload* ; autoload info
|
||
|
|
</li><li>*#readers* ; a list of (char . handler) pairs
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
<p>And the built-in constants:
|
||
|
|
</p>
|
||
|
|
<ul style="list-style-type:disc;">
|
||
|
|
<li>pi
|
||
|
|
</li><li>*stdin* *stdout* *stderr*
|
||
|
|
</li><li>*s7*
|
||
|
|
</li><li>+nan.0 -nan.0 +inf.0 -inf.0 (what crappy names! +nan.0 is a positive inexact integer that is not a number?)
|
||
|
|
</li><li>*unbound-variable-hook* *missing-close-paren-hook* *load-hook* *autoload-hook*
|
||
|
|
</li><li>*error-hook* *read-error-hook* *rootlet-redefinition-hook*
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
<p>Is it odd that the "+" in +nan.0 can't be omitted, but as used in a complex number, someone drops a "+": 1+nan.0i?
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>(<b><em class="def" id="currentfunction">*function*</em></b>) returns the name (or name and location) of the function currently being called.
|
||
|
|
<code>(define (example) (*function*))</code> returns <code>'example</code>.
|
||
|
|
Here is an example using a bacro (to access the call-time environment) and an openlet to implement a probe;
|
||
|
|
it reports any operation that the probe participates in, using *function* to get the calling function name:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (probe-eval val)
|
||
|
|
(let ((all-let (inlet)))
|
||
|
|
(for-each
|
||
|
|
(lambda (sym)
|
||
|
|
(unless (immutable? sym) ; apply-values etc
|
||
|
|
(let ((func (symbol->value sym (rootlet))))
|
||
|
|
(when (procedure? func)
|
||
|
|
(varlet all-let sym
|
||
|
|
(apply <em class="red">bacro</em> 'args
|
||
|
|
`((let-temporarily (((*s7* 'openlets) #f))
|
||
|
|
(let ((clean-args (map (lambda (arg)
|
||
|
|
(if (eq? arg probe-eval)
|
||
|
|
(probe-eval 'value)
|
||
|
|
arg))
|
||
|
|
args)))
|
||
|
|
(format *stderr* "(~S ~{~S~^ ~}) ; ~S~%"
|
||
|
|
,sym clean-args
|
||
|
|
(<em class="red">*function*</em> (outlet (outlet (curlet)))))
|
||
|
|
(apply ,func clean-args))))))))))
|
||
|
|
(symbol-table))
|
||
|
|
(varlet all-let 'value val)
|
||
|
|
(<em class="red">openlet</em> all-let)))
|
||
|
|
|
||
|
|
(define (call-any x)
|
||
|
|
(+ x 21))
|
||
|
|
|
||
|
|
(call-any (probe-eval 42)) ; prints "(+ 42 21) ; call-any", returns 63
|
||
|
|
</pre>
|
||
|
|
<p>
|
||
|
|
The second argument to *function* is the let from which to start searching for a function.
|
||
|
|
In the example above, we start the search from the let outside the bacro, since we hope to find the bacro's caller.
|
||
|
|
As a convenience, *function* takes an optional third argument specifying what information you want
|
||
|
|
about the current function. An example: <code>(*function* (curlet) 'name)</code>.
|
||
|
|
<code>name</code> returns the name (a symbol) of the current function.
|
||
|
|
<code>line</code> returns the function's definition line number.
|
||
|
|
<code>file</code> returns the function's definition file.
|
||
|
|
Other possibilities are <code>signature</code>, <code>documentation</code>,
|
||
|
|
<code>arity</code>, <code>arglist</code>, <code>value</code>, and <code>source</code>.
|
||
|
|
<code>funclet</code> returns the current function's funclet.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Currently WITH_PURE_S7:
|
||
|
|
</p>
|
||
|
|
<ul style="list-style-type:disc;">
|
||
|
|
<li>places 'pure-s7 in *features*
|
||
|
|
</li><li>omits char-ready, char-ci*, string-ci*
|
||
|
|
</li><li>omits string-fill!, vector-fill!, vector-append
|
||
|
|
</li><li>omits list->string, list->vector, string->list, vector->list, let->list
|
||
|
|
</li><li>omits string-length and vector-length
|
||
|
|
</li><li>omits cond-expand, multiple-values-bind|set!, call-with-values
|
||
|
|
</li><li>omits unquote (the name)
|
||
|
|
</li><li>omits d/f/s/l exponents
|
||
|
|
</li><li>omits make-polar and make-rectangular (use complex)
|
||
|
|
</li><li>omits exact?, inexact?, exact->inexact, inexact->exact
|
||
|
|
</li><li>omits set-current-output-port and set-current-input-port
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>Schemes vary in their treatment of (). s7 considers it a constant that evaluates to itself,
|
||
|
|
so you don't need to quote it. <code>(eq? () '())</code> is #t.
|
||
|
|
This is consistent with, for example,
|
||
|
|
<code>(eq? #f '#f)</code> which is also #t.
|
||
|
|
The standard says "the empty list is a special object of its own type", so surely either choice is
|
||
|
|
acceptable in that regard (but, sigh, the standard stupidly goes on to deny that () can evaluate to itself).
|
||
|
|
(I'm told that "is an error" means "is not portable" in the standard's weasely abuse of English; if
|
||
|
|
they mean "is not portable" why not say so?).
|
||
|
|
Some of the confusion appears to be caused by the word "list". I would describe the evaluator: "if it gets a
|
||
|
|
constant (and () is a constant) it returns that constant; if a symbol, it returns the value
|
||
|
|
associated with that symbol; if a pair, it looks at the pair's
|
||
|
|
car to decide what to do". It's kinda looney to insist on looking at the car of a list when you know () has no car!
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<!--
|
||
|
|
One place where the quote matters is in a case statement; the selector is
|
||
|
|
evaluated but the key is not:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">
|
||
|
|
> (case '() ((()) 2) (else 1)) ; in s7 this is the same as (case () ((()) 2) (else 1))
|
||
|
|
<em class="gray">2</em>
|
||
|
|
> (case '() (('()) 2) (else 1)) ; (eqv? '() ''()) is #f
|
||
|
|
<em class="gray">1</em>
|
||
|
|
;;; which parallels #f (or a number such as 2 etc):
|
||
|
|
> (case '#f ((#f) 2) (else 1))
|
||
|
|
<em class="gray">2</em>
|
||
|
|
> (case '#f (('#f) 2) (else 1)) ; (eqv? '#f ''#f) is #f
|
||
|
|
<em class="gray">1</em>
|
||
|
|
</pre>
|
||
|
|
-->
|
||
|
|
|
||
|
|
<p>Similarly, in s7, vector constants do not have to be quoted. A list constant is quoted
|
||
|
|
to keep it from being evaluated, but
|
||
|
|
#(1 2 3) is as unproblematic as "123" or 123.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<!-- there's another sense in which '() is a constant: you can't apply it to anything. ('() 0) -> error
|
||
|
|
-->
|
||
|
|
|
||
|
|
<p>These examples bring up another odd corner of scheme: else. In <code>(cond (else 1))</code>
|
||
|
|
the 'else is evaluated (like any cond test), so its value might be #f; in <code>(case 0 (else 1))</code>
|
||
|
|
it is not evaluated (like any case key), so it's just a symbol.
|
||
|
|
Since setters are local in s7,
|
||
|
|
someone can <code>(let ((else #f)) (cond (else 1)))</code> even if we protect the rootlet 'else.
|
||
|
|
Of course, in scheme this kind of trouble is pervasive, so rather than make 'else a constant
|
||
|
|
I think the best path is to use unlet:
|
||
|
|
<code>(let ((else #f)) (cond (#_else 1)))</code>. This is 1 (not ()) because the initial value of 'else
|
||
|
|
can't be changed.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>s7 handles circular lists and vectors and dotted lists with its customary aplomb.
|
||
|
|
You can pass them to memq, or print them, for example; you can even evaluate them.
|
||
|
|
The print syntax is borrowed from CL:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((lst (list 1 2 3)))
|
||
|
|
(set! (cdr (cdr (cdr lst))) lst)
|
||
|
|
lst)
|
||
|
|
<em class="gray">#1=(1 2 3 . #1#)</em>
|
||
|
|
> (let* ((x (cons 1 2))
|
||
|
|
(y (cons 3 x)))
|
||
|
|
(list x y))
|
||
|
|
<em class="gray">(#1=(1 . 2) (3 . #1#))</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p id="circularlistreader">
|
||
|
|
But should this syntax be readable as well? I'm inclined to say no because
|
||
|
|
then it is part of the language, and it doesn't look like the rest of the language.
|
||
|
|
(I think it's kind of ugly). Perhaps we could implement it via *#readers*:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre>(define circular-list-reader
|
||
|
|
(let ((known-vals #f)
|
||
|
|
(top-n -1))
|
||
|
|
(lambda (str)
|
||
|
|
|
||
|
|
(define (replace-syms lst)
|
||
|
|
;; walk through the new list, replacing our special keywords
|
||
|
|
;; with the associated locations
|
||
|
|
|
||
|
|
(define (replace-sym tree getter)
|
||
|
|
(if (keyword? (getter tree))
|
||
|
|
(let ((n (string->number (symbol->string (keyword->symbol (getter tree))))))
|
||
|
|
(if (integer? n)
|
||
|
|
(let ((lst (assoc n known-vals)))
|
||
|
|
(if lst
|
||
|
|
(set! (getter tree) (cdr lst))
|
||
|
|
(format *stderr* "#~D# is not defined~%" n)))))))
|
||
|
|
|
||
|
|
(let walk-tree ((tree (cdr lst)))
|
||
|
|
(if (pair? tree)
|
||
|
|
(begin
|
||
|
|
(if (pair? (car tree)) (walk-tree (car tree)) (replace-sym tree car))
|
||
|
|
(if (pair? (cdr tree)) (walk-tree (cdr tree)) (replace-sym tree cdr))))
|
||
|
|
tree))
|
||
|
|
|
||
|
|
;; str is whatever followed the #, first char is a digit
|
||
|
|
(let* ((len (length str))
|
||
|
|
(last-char (str (- len 1))))
|
||
|
|
(and (memv last-char '(#\= #\#)) ; is it #n= or #n#?
|
||
|
|
(let ((n (string->number (substring str 0 (- len 1)))))
|
||
|
|
(and (integer? n)
|
||
|
|
(begin
|
||
|
|
(if (not known-vals) ; save n so we know when we're done
|
||
|
|
(begin
|
||
|
|
(set! known-vals ())
|
||
|
|
(set! top-n n)))
|
||
|
|
|
||
|
|
(if (char=? last-char #\=) ; #n=
|
||
|
|
(and (eqv? (peek-char) #\() ; eqv? since peek-char can return #<eof>
|
||
|
|
(let ((cur-val (assoc n known-vals)))
|
||
|
|
;; associate the number and the list it points to
|
||
|
|
;; if cur-val, perhaps complain? (#n# redefined)
|
||
|
|
(let ((lst (catch #t
|
||
|
|
read
|
||
|
|
(lambda args ; a read error
|
||
|
|
(set! known-vals #f) ; so clear our state
|
||
|
|
(apply throw args))))) ; and pass the error on up
|
||
|
|
(if cur-val
|
||
|
|
(set! (cdr cur-val) lst)
|
||
|
|
(set! known-vals
|
||
|
|
(cons (set! cur-val (cons n lst)) known-vals))))
|
||
|
|
|
||
|
|
(if (= n top-n) ; replace our special keywords
|
||
|
|
(let ((result (replace-syms cur-val)))
|
||
|
|
(set! known-vals #f) ; '#1=(#+gsl #1#) -> '(:1)!
|
||
|
|
result)
|
||
|
|
(cdr cur-val))))
|
||
|
|
; #n=<not a list>?
|
||
|
|
;; else it's #n# — set a marker for now since we may not
|
||
|
|
;; have its associated value yet. We use a symbol name that
|
||
|
|
;; string->number accepts.
|
||
|
|
(symbol->keyword
|
||
|
|
(symbol (number->string n) (string #\null) " "))))))
|
||
|
|
; #n<not an integer>?
|
||
|
|
))))) ; #n<something else>?
|
||
|
|
|
||
|
|
(do ((i 0 (+ i 1)))
|
||
|
|
((= i 10))
|
||
|
|
;; load up all the #n cases
|
||
|
|
(set! *#readers*
|
||
|
|
(cons (cons (integer->char (+ i (char->integer #\0))) circular-list-reader)
|
||
|
|
*#readers*)))
|
||
|
|
<!-- ) -->
|
||
|
|
> '#1=(1 2 . #1#)
|
||
|
|
<em class="gray">#1=(1 2 . #1#)</em>
|
||
|
|
> '#1=(1 #2=(2 . #2#) . #1#)
|
||
|
|
<em class="gray">#2=(1 #1=(2 . #1#) . #2#)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>And of course, we can treat these as labels:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(let ((ctr 0)) #1=(begin (format () "~D " ctr) (set! ctr (+ ctr 1)) (if (< ctr 4) #1# (newline))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>which prints "0 1 2 3" and a newline.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<br>
|
||
|
|
|
||
|
|
|
||
|
|
<p>Length returns +inf.0 if passed a circular list, and returns a negative
|
||
|
|
number if passed a dotted list. In the dotted case, the absolute value of the length is the list length not counting
|
||
|
|
the final cdr. <code>(define (circular? lst) (infinite? (length lst)))</code>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
<em class="def" id="cyclicsequences">cyclic-sequences</em> returns a list of the cyclic
|
||
|
|
sequences in its argument, or nil.
|
||
|
|
<code>(define (cyclic? obj) (pair? (cyclic-sequences obj)))</code>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Here's an amusing use of circular lists:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define (for-each-permutation func vals)
|
||
|
|
;; apply func to every permutation of vals:
|
||
|
|
;; (for-each-permutation (lambda args (format () "~{~A~^ ~}~%" args)) '(1 2 3))
|
||
|
|
(define (pinner cur nvals len)
|
||
|
|
(if (= len 1)
|
||
|
|
(apply func (car nvals) cur)
|
||
|
|
(do ((i 0 (+ i 1))) ; I suppose a named let would be more Schemish
|
||
|
|
((= i len))
|
||
|
|
(let ((start nvals))
|
||
|
|
(set! nvals (cdr nvals))
|
||
|
|
(let ((cur1 (cons (car nvals) cur))) ; add (car nvals) to our arg list
|
||
|
|
(set! (cdr start) (cdr nvals)) ; splice out that element and
|
||
|
|
(pinner cur1 (cdr start) (- len 1)) ; pass a smaller circle on down, "wheels within wheels"
|
||
|
|
(set! (cdr start) nvals)))))) ; restore original circle
|
||
|
|
(let ((len (length vals)))
|
||
|
|
(set-cdr! (list-tail vals (- len 1)) vals) ; make vals into a circle
|
||
|
|
(pinner () vals len)
|
||
|
|
(set-cdr! (list-tail vals (- len 1)) ()))) ; restore its original shape
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>s7 and Snd use "*" in a variable name, *features* for example, to indicate
|
||
|
|
that the variable is predefined. It may occur unprotected in a macro, for
|
||
|
|
example. The "*" doesn't mean that the variable is special in the CL sense of dynamic scope,
|
||
|
|
but some clear marker is needed for a global variable so that the programmer
|
||
|
|
doesn't accidentally step on it.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Although a variable name's first character is more restricted, currently
|
||
|
|
only #\null, #\newline, #\tab, #\space, #\), #\(, #\", and #\; can't
|
||
|
|
occur within the name. I did not originally include double-quote in this set, so wild stuff like
|
||
|
|
<code>(let ((nam""e 1)) nam""e)</code>
|
||
|
|
would work, but that means that <code>'(1 ."hi")</code> is parsed as a 1 and the
|
||
|
|
symbol <code>."hi"</code>, and <code>(string-set! x"hi")</code> is an error.
|
||
|
|
The first character should not be #\#, #\', #\`, #\,, #\:, or any of those mentioned above,
|
||
|
|
and some characters can't occur by themselves. For example, "." is not a legal variable
|
||
|
|
name, but ".." is.
|
||
|
|
These weird symbols have to be printed sometimes:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (list 1 (string->symbol (string #\; #\" #\\)) 2)
|
||
|
|
<em class="gray">(1 ;"\ 2)</em> <!-- " -->
|
||
|
|
> (list 1 (string->symbol (string #\.)) 2)
|
||
|
|
<em class="gray">(1 . 2)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>which is a mess. Guile prints the first as <code>(1 #{\;\"\\}# 2)</code>.
|
||
|
|
In CL and some Schemes:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">[1]> (list 1 (intern (coerce (list #\; #\" #\\) 'string)) 2) ; thanks to Rob Warnock
|
||
|
|
<em class="gray">(1 |;"\\| 2)</em> <!-- " -->
|
||
|
|
[2]> (equalp 'A '|A|) ; in CL case matters here
|
||
|
|
<em class="gray">T</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>This is clean, and has the weight of tradition behind it, but
|
||
|
|
I think I'll use "symbol" instead:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (list 1 (string->symbol (string #\; #\" #\\)) 2)
|
||
|
|
<em class="gray">(1 (symbol ";\"\\") 2)</em> <!-- " -->
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
This output is readable, and does not eat up perfectly good
|
||
|
|
characters like vertical bar, but it means we can't easily use
|
||
|
|
variable names like "| e t c |". We could allow a name to
|
||
|
|
contain any characters if it starts and ends with "|",
|
||
|
|
but then one vertical bar is trouble. (The symbol function
|
||
|
|
actually accepts any number of string arguments which it concatenates
|
||
|
|
to form the new symbol name).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
These symbols are not just an optimization of string comparison:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-macro (hi a)
|
||
|
|
(let ((funny-name (string->symbol ";")))
|
||
|
|
`(let ((,funny-name ,a)) (+ 1 ,funny-name))))
|
||
|
|
<em class="gray">hi</em>
|
||
|
|
> (hi 2)
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (macroexpand (hi 2))
|
||
|
|
<em class="gray">(let ((; 2)) (+ 1 ;))</em> ; for a good time, try (string #\")
|
||
|
|
|
||
|
|
> (define-macro (hi a)
|
||
|
|
(let ((funny-name (string->symbol "| e t c |")))
|
||
|
|
`(let ((,funny-name ,a)) (+ 1 ,funny-name))))
|
||
|
|
<em class="gray">hi</em>
|
||
|
|
> (hi 2)
|
||
|
|
<em class="gray">3</em>
|
||
|
|
> (macroexpand (hi 2))
|
||
|
|
<em class="gray">(let ((| e t c | 2)) (+ 1 | e t c |))</em>
|
||
|
|
> (let ((funny-name (string->symbol "| e t c |"))) ; now use it as a keyword arg to a function
|
||
|
|
(apply define* `((func (,funny-name 32)) (+ ,funny-name 1)))
|
||
|
|
;; (procedure-source func) is (lambda* ((| e t c | 32)) (+ | e t c | 1))
|
||
|
|
(apply func (list (symbol->keyword funny-name) 2)))
|
||
|
|
<em class="gray">3</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>I hope that makes you as happy as it makes me!
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p id="legolambda">The built-in syntactic forms, such as "begin", are almost first-class citizens.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (let ((progn begin))
|
||
|
|
(progn
|
||
|
|
(define x 1)
|
||
|
|
(set! x 3)
|
||
|
|
(+ x 4)))
|
||
|
|
<em class="gray">7</em>
|
||
|
|
> (let ((function lambda))
|
||
|
|
((function (a b) (list a b)) 3 4))
|
||
|
|
<em class="gray">(3 4)</em>
|
||
|
|
> (apply begin '((define x 3) (+ x 2)))
|
||
|
|
<em class="gray">5</em>
|
||
|
|
> ((lambda (n) (apply n '(((x 1)) (+ x 2)))) let)
|
||
|
|
<em class="gray">3</em>
|
||
|
|
|
||
|
|
(define-macro (symbol-set! var val) ; like CL's set
|
||
|
|
`(apply set! ,var ',val ())) ; trailing nil is just to make apply happy — apply*?
|
||
|
|
|
||
|
|
(define-macro (progv vars vals . body)
|
||
|
|
`(apply (apply lambda ,vars ',body) ,vals))
|
||
|
|
|
||
|
|
> (let ((s '(one two)) (v '(1 2))) (progv s v (+ one two)))
|
||
|
|
<em class="gray">3</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>We can snap together program fragments ("look Ma, no macros!"):
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(let* ((x 3)
|
||
|
|
(arg '(x))
|
||
|
|
(body `((+ ,x x 1))))
|
||
|
|
((apply lambda arg body) 12)) ; "legolambda"?
|
||
|
|
|
||
|
|
(define (engulph form)
|
||
|
|
(let ((body `(let ((L ()))
|
||
|
|
(do ((i 0 (+ i 1)))
|
||
|
|
((= i 10) (reverse L))
|
||
|
|
(set! L (cons ,form L))))))
|
||
|
|
(define function (apply lambda () (list (copy body))))
|
||
|
|
(function)))
|
||
|
|
|
||
|
|
(let ()
|
||
|
|
(define (hi a) (+ a x))
|
||
|
|
((apply let '((x 32)) (list (procedure-source hi))) 12)) ; one function, many closures?
|
||
|
|
|
||
|
|
(let ((ctr -1)) ; (enum zero one two) but without using a macro
|
||
|
|
(apply begin
|
||
|
|
(map (lambda (symbol)
|
||
|
|
(set! ctr (+ ctr 1))
|
||
|
|
(list 'define symbol ctr)) ; e.g. '(define zero 0)
|
||
|
|
'(zero one two)))
|
||
|
|
(+ zero one two))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>But there's a prettier way to implement enum ("transparent-for-each"):
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define-macro (enum . args)
|
||
|
|
`(for-each define ',args (iota (length ',args))))
|
||
|
|
<em class="gray">enum</em>
|
||
|
|
> (enum a b c)
|
||
|
|
<em class="gray">#<unspecified></em>
|
||
|
|
> b
|
||
|
|
<em class="gray">1</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Now we notice that <code>(case 0.0 ((0.0) 1) (else 0))</code> is 1, but
|
||
|
|
how to get pi into a key list?
|
||
|
|
</p>
|
||
|
|
<pre class="indented">> (apply case 'pi `(((,pi) 1) (else 0)))
|
||
|
|
<em class="gray">1</em>
|
||
|
|
> (let ((lst '(1 2))) (apply case 'lst `(((,lst) 1) (else 0))))
|
||
|
|
<em class="gray">1</em> ; same trick puts a list in the keys
|
||
|
|
> (apply case '+nan.0 `(((,+nan.0) 1) (else 0)))
|
||
|
|
<em class="gray">0</em> ; (eqv? +nan.0 +nan.0) is #f
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p><code>(apply define ...)</code> is similar to CL's set.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> ((apply define-macro '((m a) `(+ 1 ,a))) 3)
|
||
|
|
<em class="gray">4</em>
|
||
|
|
> ((apply define '((hi a) (+ a 1))) 3)
|
||
|
|
<em class="gray">4</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Apply let is very similar to eval:
|
||
|
|
</p>
|
||
|
|
<pre>> (apply let '((a 2) (b 3)) '((+ a b)))
|
||
|
|
<em class="gray">5</em>
|
||
|
|
> (eval '(+ a b) (inlet 'a 2 'b 3))
|
||
|
|
<em class="gray">5</em>
|
||
|
|
> ((apply lambda '(a b) '((+ a b))) 2 3)
|
||
|
|
<em class="gray">5</em>
|
||
|
|
> (apply let '((a 2) (b 3)) '((list + a b))) ; a -> 2, b -> 3
|
||
|
|
<em class="gray">(+ 2 3)</em>
|
||
|
|
</pre>
|
||
|
|
<p>The redundant-looking double lists are for apply's benefit. We could
|
||
|
|
use a trailing null instead (mimicking apply* in some ancient lisps):
|
||
|
|
</p>
|
||
|
|
<pre>> (apply let '((a 2) (b 3)) '(list + a b) ())
|
||
|
|
<em class="gray">(+ 2 3)</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Scheme claims that it evaluates the car of an expression, then calls the
|
||
|
|
result with the rest of the expression. So <code>((if x + -) y z)</code> calls either
|
||
|
|
<code>(+ y z)</code> or <code>(- y z)</code> depending on x.
|
||
|
|
But only s7, as far as I know, handles <code>((if x or and) y z)</code>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>catch, dynamic-wind, and many of the other functions that take function
|
||
|
|
arguments in standard Scheme, accept macros in s7, and dynamic-wind accepts
|
||
|
|
#f as the initial and final entries.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
Currently, you can't set! a built-in syntactic keyword to some new value:
|
||
|
|
<code>(set! if 3)</code>.
|
||
|
|
let-temporarily uses set!, so <code>(let-temporarily ((if 3))...)</code>
|
||
|
|
is also unlikely to work.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<p>Speaking of speed... It is widely believed
|
||
|
|
that a Scheme with first class everything can't hope to compete with any
|
||
|
|
"real" Scheme. Humph I say. Take this little example (which is not
|
||
|
|
so misleading that I feel guilty about it):
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (do-loop n)
|
||
|
|
(do ((i 0 (+ i 1)))
|
||
|
|
((= i n))
|
||
|
|
(if (zero? (modulo i 1000))
|
||
|
|
(display ".")))
|
||
|
|
(newline))
|
||
|
|
|
||
|
|
(for-each do-loop (list 1000 1000000 10000000))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>In s7, that takes 0.09 seconds on my home machine. In tinyScheme, from
|
||
|
|
whence we sprang, it takes 85 seconds. In the chicken interpreter, 5.3
|
||
|
|
seconds, and after compilation (using -O2) of the chicken compiler output,
|
||
|
|
0.75 seconds. So, s7 is comparable to chicken in speed, even though chicken
|
||
|
|
is compiling to C. I think Guile 2.0.9 takes about 1 second.
|
||
|
|
The equivalent in CL:
|
||
|
|
clisp interpreted 9.3 seconds, compiled 0.85 seconds; sbcl 0.21 seconds.
|
||
|
|
Similarly, s7 computes (fib 40) in 0.8 seconds, approximately the same as sbcl.
|
||
|
|
Guile 2.2.3 takes 7 seconds.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="small">
|
||
|
|
<p>
|
||
|
|
s7's timing tests are in its tools directory. The script
|
||
|
|
valcall.scm runs them through callgrind. The results
|
||
|
|
can be found at the end of s7.c.
|
||
|
|
If you're interested in the standard Scheme benchmarks, it
|
||
|
|
is possible to add s7 to that package. First, s7-prelude.scm
|
||
|
|
and s7-postlude.scm need to be added to the benchmarks src directory.
|
||
|
|
s7-postlude.scm can be empty. My version of s7-prelude.scm is:
|
||
|
|
</p>
|
||
|
|
<pre>(define (this-scheme-implementation-name) "s7")
|
||
|
|
(define exact-integer? integer?)
|
||
|
|
(define (exact-integer-sqrt i) (let ((sq (floor (sqrt i)))) (values sq (- i (* sq sq)))))
|
||
|
|
(define inexact exact->inexact)
|
||
|
|
(define exact inexact->exact)
|
||
|
|
(define (square x) (* x x))
|
||
|
|
(define (vector-map f v) (copy v)) ; for quicksort.scm
|
||
|
|
(define-macro (import . args) #f)
|
||
|
|
(define (jiffies-per-second) 1000)
|
||
|
|
(define (current-jiffy) (round (* (jiffies-per-second) (*s7* 'cpu-time))))
|
||
|
|
(define (current-second) (floor (*s7* 'cpu-time)))
|
||
|
|
</pre>
|
||
|
|
<p>
|
||
|
|
If you want to run gcbench, add the define-record-type macro from r7rs.scm.
|
||
|
|
Here are the diffs for the bench script:
|
||
|
|
</p>
|
||
|
|
<pre>141a142
|
||
|
|
> S7=${S7:-"/home/bil/motif-snd/repl"}
|
||
|
|
187a189
|
||
|
|
> s7 for s7
|
||
|
|
406a409,421
|
||
|
|
> # Definitions specific to s7
|
||
|
|
>
|
||
|
|
> s7_comp ()
|
||
|
|
> {
|
||
|
|
> :
|
||
|
|
> }
|
||
|
|
>
|
||
|
|
> s7_exec ()
|
||
|
|
> {
|
||
|
|
> time ${S7} "$1" < "$2"
|
||
|
|
> }
|
||
|
|
>
|
||
|
|
> # -----------------------------------------------------------------------------
|
||
|
|
940a957,966
|
||
|
|
>
|
||
|
|
> s7) NAME='s7'
|
||
|
|
> COMP=s7_comp
|
||
|
|
> EXEC=s7_exec
|
||
|
|
> COMPOPTS=""
|
||
|
|
> EXTENSION="scm"
|
||
|
|
> EXTENSIONCOMP="scm"
|
||
|
|
> COMPCOMMANDS=""
|
||
|
|
> EXECCOMMANDS=""
|
||
|
|
> ;;
|
||
|
|
</pre>
|
||
|
|
<p>
|
||
|
|
I call the standalone version of s7 "repl", so its path
|
||
|
|
is /home/bil/motif-snd/repl. To build repl, get s7.tar.gz
|
||
|
|
from https://ccrma.stanford.edu/software/s7/s7.tar.gz;
|
||
|
|
if not using gcc or clang, add the empty file mus-config.h to the tarball's contents,
|
||
|
|
then (in Linux):
|
||
|
|
</p>
|
||
|
|
<pre>gcc s7.c -o repl -DWITH_MAIN -I. -O2 -g -ldl -lm -Wl,-export-dynamic -Wno-stringop-overflow
|
||
|
|
</pre>
|
||
|
|
<p>For timing tests, I add "-fomit-frame-pointer -funroll-loops -march=native".
|
||
|
|
mus-config.h normally has
|
||
|
|
</p>
|
||
|
|
<pre>#define HAVE_COMPLEX_NUMBERS 1
|
||
|
|
#define HAVE_COMPLEX_TRIG 1
|
||
|
|
</pre>
|
||
|
|
<p>
|
||
|
|
but s7.c has defaults, so mus-config.h can be empty, or absent.
|
||
|
|
Finally, go back to the benchmarks directory and
|
||
|
|
</p>
|
||
|
|
<pre>bench s7 all
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
The benchmark compiler.scm assumes that small
|
||
|
|
integers can be compared with eq? (via assq), which is incorrect.
|
||
|
|
pi.scm and chudnovsky.scm need the gmp version of s7.
|
||
|
|
I ran the bench script on an AMD 3950X machine, and got these results (in seconds):
|
||
|
|
ack: 6.6, array1: 6.4, browse: 11.2, bv2string: 4.1, cat: 0.4,
|
||
|
|
compiler: 16.9, conform: 30.0, cpstak: 42.8, ctak: 16.6, deriv: 9.7,
|
||
|
|
destruc: 8.6, diviter: 3.7, divrec: 4.6, dynamic: 12.6, earley: 25.5,
|
||
|
|
equal: 0.3, fft: 12.5, fib: 6.1, fibc: 8.6, fibfp: 1.1, gcbench: 12.9,
|
||
|
|
grahps: 72.5, lattice: 63.4, matrix: 21.0, maze: 11.4, mazefun: 9.8,
|
||
|
|
mbrot: 12.6, mbrotZ: 8.0, mperm: 18.9, nboyer: 20.1, nqueens: 27.0,
|
||
|
|
ntakl: 8.0, nucleic: 8.3, paraffins: 4.4, parsing: 20.7, peval: 15.2,
|
||
|
|
pnpoly: 9.8, primes: 10.2, puzzle: 10.2, quicksort: 40.0, ray: 8.3,
|
||
|
|
read1: 0.2, sboyer: 19.1, scheme: 29.5, simplex: 26.9, slatex: 4.2,
|
||
|
|
string: 0.8, sum1: 0.2, sum: 4.1, sumfp: 2.2, tail: 0.1, tak: 7.1,
|
||
|
|
takl: 8.1, triangl: 16.4, wc: 4.9. In the gmp case, chudnovsky: 0.017, pi: .01.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>In s7, there is only one kind of begin statement,
|
||
|
|
and it can contain both definitions and expressions. These are evaluated in the order
|
||
|
|
in which they occur, and in the environment at the point of the evaluation. I think
|
||
|
|
of it as being a little REPL. begin does not introduce a new frame in
|
||
|
|
the current environment, so defines happen in the enclosing environment.
|
||
|
|
Finally, begin, explicit or otherwise, does not pretend to emulate letrec*.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>If we allow defines anywhere, the notion of "lexical scope" becomes problematic.
|
||
|
|
Scheme is already a mess in that regard: take
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(let ((x 1))
|
||
|
|
(do ((y x x)
|
||
|
|
(x 3))
|
||
|
|
((> y 1) y)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>In <code>(y x x)</code> the first x is the outer one, and the second is the
|
||
|
|
following do variable, so this returns 3! But sticking to define, in
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(let ((x 1))
|
||
|
|
(define y x)
|
||
|
|
(define x 2)
|
||
|
|
y)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>s7 returns 1 even though technically the second x is in y's environment.
|
||
|
|
Since we treat this as a REPL, y gets its value from the only x defined at
|
||
|
|
the point it is defined. However,
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(let ((x 1))
|
||
|
|
(define y (lambda () x))
|
||
|
|
(define x 2)
|
||
|
|
(y))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>returns 2 in s7 because the x in y's function body is not evaluated
|
||
|
|
until after the second x is defined.
|
||
|
|
The define propagates backwards, but:
|
||
|
|
<code>(list x (define x 0))</code>, or <code>(list x (begin (define x 0) x))</code>.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p id="r7rs">The r7rs compatibility code is in r7rs.scm. I used to include it here, but
|
||
|
|
as r7rs grew, this section got too large. In general, all the conversion routines in
|
||
|
|
r7rs are handled in s7 via generic functions, records are classes, and so on.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
|
||
|
|
<p>"Life", a poem.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(+(*(+))(*)(+(+)(+)(*)))
|
||
|
|
(((((lambda () (lambda () (lambda () (lambda () 1))))))))
|
||
|
|
(+ (((lambda () values)) 1 2 3))
|
||
|
|
(map apply (list map) (list map) (list (list *)) '((((1 2)) ((3 4 5)))))
|
||
|
|
(do ((do do do)) (do do do))
|
||
|
|
(*(*)(*) (+)(+) 1)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
</div>
|
||
|
|
|
||
|
|
</blockquote>
|
||
|
|
<br><br>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="topheader" id="FFIexamples">FFI examples</div>
|
||
|
|
|
||
|
|
<p>s7 exists only to serve as an extension of some other application, so
|
||
|
|
it is primarily a foreign function interface. s7.h has lots of comments about the individual
|
||
|
|
functions. Here I'll collect some complete examples. s7.c depends on the following
|
||
|
|
compile-time flags:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">SIZEOF_VOID_P 8 (default) or 4.
|
||
|
|
WITH_GMP 1 if you want multiprecision arithmetic (requires gmp, mpfr, and mpc, default is 0)
|
||
|
|
HAVE_COMPLEX_NUMBERS 1 if your compiler supports complex numbers
|
||
|
|
HAVE_COMPLEX_TRIG 1 if your math library has complex versions of the trig functions
|
||
|
|
DISABLE_DEPRECATED 1 if you want to make sure you're not using any deprecated s7 stuff (default is 0)
|
||
|
|
|
||
|
|
WITH_IMMUTATBLE_UNQUOTE 1 if you want "unquote" omitted (default is 0)
|
||
|
|
WITH_EXTRA_EXPONENT_MARKERS 1 if you want "d", "f", "l", and "s" in addition to "e" as exponent markers (default is 0)
|
||
|
|
if someone defends these exponent markers, ask him to read 1l11+11l1i
|
||
|
|
(in 2 million lines of open-source Scheme, there is not one use of these silly things)
|
||
|
|
WITH_SYSTEM_EXTRAS 1 if you want some additional OS-related functions built-in (default is 0)
|
||
|
|
WITH_MAIN 1 if you want s7.c to include a main program section that runs a REPL.
|
||
|
|
WITH_C_LOADER 1 if you want to be able to load shared object files with load.
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>See the comment at the start of s7.c for more information about these switches.
|
||
|
|
s7.h defines the two main number types: s7_int and s7_double.
|
||
|
|
The examples that follow show:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<ul>
|
||
|
|
<li><a href="#repl">read-eval-print loop (and emacs)</a>
|
||
|
|
</li><li><a href="#defun">define a function with arguments and a returned value, and define a variable </a>
|
||
|
|
</li><li><a href="#defvar">call a Scheme function from C, and get/set Scheme variable values in C</a>
|
||
|
|
</li><li><a href="#juce">C++ and Juce</a>
|
||
|
|
</li><li><a href="#sndlib">load sndlib using the Xen functions and macros</a>
|
||
|
|
</li><li><a href="#pwstype">add a new Scheme type and a procedure with a setter</a>
|
||
|
|
</li><li><a href="#functionportexample">redirect display output to a C procedure</a>
|
||
|
|
</li><li><a href="#extendop">extend a built-in operator ("+" in this case)</a>
|
||
|
|
</li><li><a href="#definestar1">C-side define* (s7_define_function_star)</a>
|
||
|
|
</li><li><a href="#definemacro1">C-side define-macro (s7_define_macro)</a>
|
||
|
|
</li><li><a href="#definegeneric">define a generic function in C</a>
|
||
|
|
</li><li><a href="#signal">signal handling (C-C to break out of an infinite loop)</a>
|
||
|
|
</li><li><a href="#notify">notification in C that a Scheme variable has been set!</a>
|
||
|
|
</li><li><a href="#namespace">Load C defined stuff into a separate namespace</a>
|
||
|
|
</li><li><a href="#Cerrors">Error handling in C</a>
|
||
|
|
</li><li><a href="#testhook">Hooks in C and Scheme</a>
|
||
|
|
</li><li><a href="#dload">Load a C module dynamically</a>
|
||
|
|
</li><li><a href="#gmpex">gmp and friends</a>
|
||
|
|
</li><li><a href="#gdb">gdb</a>
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="repl"><h4>A simple listener</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
|
||
|
|
s7 = <em class="red">s7_init</em>(); /* initialize the interpreter */
|
||
|
|
while (1) /* fire up a read-eval-print loop */
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> "); /* prompt for input */
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{ /* evaluate the input and print the result */
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
<em class="red">s7_eval_c_string</em>(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* if not using gcc or clang, make mus-config.h (it can be empty), then
|
||
|
|
*
|
||
|
|
* gcc -c s7.c -I.
|
||
|
|
* gcc -o repl repl.c s7.o -lm -I. -ldl
|
||
|
|
*
|
||
|
|
* run it:
|
||
|
|
*
|
||
|
|
* repl
|
||
|
|
* > (+ 1 2)
|
||
|
|
* <em class="gray">3</em>
|
||
|
|
* > (define (add1 x) (+ 1 x))
|
||
|
|
* <em class="gray">add1</em>
|
||
|
|
* > (add1 2)
|
||
|
|
* <em class="gray">3</em>
|
||
|
|
* > (exit)
|
||
|
|
*
|
||
|
|
* for long-term happiness in linux use:
|
||
|
|
* gcc -o repl repl.c s7.o -Wl,-export-dynamic -lm -I. -ldl
|
||
|
|
* clang also needs -fPIC I think
|
||
|
|
* freebsd:
|
||
|
|
* gcc -o repl repl.c s7.o -Wl,-export-dynamic -lm -I.
|
||
|
|
* osx:
|
||
|
|
* gcc -o repl repl.c s7.o -lm -I.
|
||
|
|
* openbsd:
|
||
|
|
* gcc -o repl repl.c s7.o -I. -ftrampolines -Wl,-export-dynamic -lm
|
||
|
|
*/
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<p>Since this reads stdin and writes stdout, it can be run as a Scheme subjob of emacs.
|
||
|
|
One (inconvenient) way to do this is to set the emacs variable scheme-program-name to
|
||
|
|
the name of the exectuable created above ("repl"), then call the emacs function run-scheme:
|
||
|
|
M-x eval-expression in emacs, followed by (setq scheme-program-name "repl"), then
|
||
|
|
M-x run-scheme, and you're talking to s7 in emacs. Of course, this connection can be
|
||
|
|
customized indefinitely. See, for example, inf-snd.el in the Snd package.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Here are the not-always-built-in indentations I use in emacs:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(put 'with-let 'scheme-indent-function 1)
|
||
|
|
(put 'with-baffle 'scheme-indent-function 0)
|
||
|
|
(put 'with-sound 'scheme-indent-function 1)
|
||
|
|
(put 'catch 'scheme-indent-function 1)
|
||
|
|
(put 'lambda* 'scheme-indent-function 1)
|
||
|
|
(put 'when 'scheme-indent-function 1)
|
||
|
|
(put 'let-temporarily 'scheme-indent-function 1)
|
||
|
|
(put 'let*-temporarily 'scheme-indent-function 1)
|
||
|
|
(put 'call-with-input-string 'scheme-indent-function 1)
|
||
|
|
(put 'unless 'scheme-indent-function 1)
|
||
|
|
(put 'letrec* 'scheme-indent-function 1)
|
||
|
|
(put 'sublet 'scheme-indent-function 1)
|
||
|
|
(put 'varlet 'scheme-indent-function 1)
|
||
|
|
(put 'case* 'scheme-indent-function 1)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>To read stdin while working in a GUI-based program is trickier. In glib, you can use
|
||
|
|
something like this:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<pre>static gboolean read_stdin(GIOChannel *source, GIOCondition condition, gpointer data)
|
||
|
|
{
|
||
|
|
/* here read from g_io_channel_unix_get_fd(source) and call s7_eval_string */
|
||
|
|
return(true);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* ... during initialization ... */
|
||
|
|
|
||
|
|
GIOChannel *channel;
|
||
|
|
channel = g_io_channel_unix_new(STDIN_FILENO); /* watch stdin */
|
||
|
|
stdin_id = g_io_add_watch_full(channel, /* and call read_stdin above if input is noticed */
|
||
|
|
G_PRIORITY_DEFAULT,
|
||
|
|
(GIOCondition)(G_IO_IN | G_IO_HUP | G_IO_ERR),
|
||
|
|
<em class="red">read_stdin</em>, NULL, NULL);
|
||
|
|
g_io_channel_unref(channel);
|
||
|
|
</pre></div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
<p>Here's a version that uses libtecla for the line editor:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
#include <libtecla.h>
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
char *buffer;
|
||
|
|
char response[1024];
|
||
|
|
GetLine *gl; /* The tecla line editor */
|
||
|
|
|
||
|
|
gl = new_GetLine(500, 5000);
|
||
|
|
s7 = s7_init();
|
||
|
|
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
buffer = gl_get_line(gl, "> ", NULL, 0);
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
fprintf(stdout, "\n");
|
||
|
|
}
|
||
|
|
}
|
||
|
|
gl = del_GetLine(gl);
|
||
|
|
}
|
||
|
|
|
||
|
|
/*
|
||
|
|
* gcc -c s7.c -I. -O2 -g3
|
||
|
|
* gcc -o ex1 ex1.c s7.o -lm -I. -ltecla -ldl
|
||
|
|
*/
|
||
|
|
</pre></div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
<p>A repl (based on repl.scm or nrepl.scm) is built into s7. Include the compiler flag -DWITH_MAIN:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">gcc -o nrepl s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl -DWITH_MAIN -DWITH_NOTCURSES -lnotcurses-core
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<p id="beginhook">
|
||
|
|
Common Lisp has something called "evalhook" that makes it possible
|
||
|
|
to insert your own function into the eval loop. In s7, we have a "begin_hook" which sits at the opening of many begin blocks
|
||
|
|
(implicit or explicit). begin_hook is a (C) function;
|
||
|
|
if it sets its bool argument to true,
|
||
|
|
s7 interrupts the current evaluation.
|
||
|
|
Here is a version of the REPL in which begin_hook watches for C-g to interrupt
|
||
|
|
some long computation:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<pre>/* terminal-based REPL,
|
||
|
|
* an expansion of the <a href="#repl">read-eval-print loop</a> program above.
|
||
|
|
* type C-g to interrupt an evaluation.
|
||
|
|
*/
|
||
|
|
#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
#include <termios.h>
|
||
|
|
#include <signal.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static struct termios save_buf, buf;
|
||
|
|
|
||
|
|
static void sigcatch(int n)
|
||
|
|
{
|
||
|
|
/* put things back the way they were */
|
||
|
|
tcsetattr(fileno(stdin), TCSAFLUSH, &save_buf);
|
||
|
|
exit(0);
|
||
|
|
}
|
||
|
|
|
||
|
|
static char buffer[512];
|
||
|
|
static int type_ahead_point = 0;
|
||
|
|
|
||
|
|
static void <em class="red">watch_for_c_g</em>(s7_scheme *sc, bool *all_done)
|
||
|
|
{
|
||
|
|
char c;
|
||
|
|
/* watch for C-g without blocking, save other chars as type-ahead */
|
||
|
|
tcsetattr(fileno(stdin), TCSAFLUSH, &buf);
|
||
|
|
if (read(fileno(stdin), &c, 1) == 1)
|
||
|
|
{
|
||
|
|
if (c == 7) /* C-g */
|
||
|
|
{
|
||
|
|
*all_done = true;
|
||
|
|
type_ahead_point = 0;
|
||
|
|
}
|
||
|
|
else buffer[type_ahead_point++] = c;
|
||
|
|
}
|
||
|
|
tcsetattr(fileno(stdin), TCSAFLUSH, &save_buf);
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
bool use_begin_hook;
|
||
|
|
|
||
|
|
use_begin_hook = (tcgetattr(fileno(stdin), &save_buf) >= 0);
|
||
|
|
if (use_begin_hook)
|
||
|
|
{
|
||
|
|
buf = save_buf;
|
||
|
|
buf.c_lflag &= ~ICANON;
|
||
|
|
buf.c_cc[VMIN] = 0;
|
||
|
|
buf.c_cc[VTIME] = 0;
|
||
|
|
|
||
|
|
signal(SIGINT, sigcatch);
|
||
|
|
signal(SIGQUIT, sigcatch);
|
||
|
|
signal(SIGTERM, sigcatch);
|
||
|
|
}
|
||
|
|
s7 = s7_init();
|
||
|
|
|
||
|
|
if (argc == 2)
|
||
|
|
{
|
||
|
|
fprintf(stderr, "load %s\n", argv[1]);
|
||
|
|
if (!s7_load(s7, argv[1]))
|
||
|
|
fprintf(stderr, "can't find %s\n", argv[1]);
|
||
|
|
}
|
||
|
|
else
|
||
|
|
{
|
||
|
|
char response[1024];
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets((char *)(buffer + type_ahead_point), 512 - type_ahead_point, stdin);
|
||
|
|
type_ahead_point = 0;
|
||
|
|
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
|
||
|
|
if (use_begin_hook)
|
||
|
|
<em class="red">s7_set_begin_hook</em>(s7, watch_for_c_g);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
if (use_begin_hook)
|
||
|
|
<em class="red">s7_set_begin_hook</em>(s7, NULL);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
if (use_begin_hook)
|
||
|
|
tcsetattr(fileno(stdin), TCSAFLUSH, &save_buf);
|
||
|
|
}
|
||
|
|
</pre></div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="defun"><h4>Define a function with arguments and a returned value, and a variable</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer add1(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
/* all added functions have this form, args is a list,
|
||
|
|
* s7_car(args) is the first arg, etc
|
||
|
|
*/
|
||
|
|
if (<em class="red">s7_is_integer</em>(s7_car(args)))
|
||
|
|
return(<em class="red">s7_make_integer</em>(sc, 1 + <em class="red">s7_integer</em>(s7_car(args))));
|
||
|
|
return(s7_wrong_type_arg_error(sc, "add1", 1, s7_car(args), "an integer"));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
|
||
|
|
s7 = s7_init();
|
||
|
|
|
||
|
|
s7_define_function(s7, "add1", add1, 1, 0, false, "(add1 int) adds 1 to int");
|
||
|
|
/* add the function "add1" to the interpreter.
|
||
|
|
* 1, 0, false -> one required arg,
|
||
|
|
* no optional args,
|
||
|
|
* no "rest" arg
|
||
|
|
*/
|
||
|
|
<em class="red">s7_define_variable</em>(s7, "my-pi", <em class="red">s7_make_real</em>(s7, 3.14159265));
|
||
|
|
|
||
|
|
while (1) /* fire up a "repl" */
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> "); /* prompt for input */
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response); /* evaluate input and write the result */
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* doc7
|
||
|
|
* > my-pi
|
||
|
|
* <em class="gray">3.14159265</em>
|
||
|
|
* > (+ 1 (add1 1))
|
||
|
|
* <em class="gray">3</em>
|
||
|
|
* > (exit)
|
||
|
|
*/
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="defvar"><h4>Call a Scheme-defined function from C, and get/set Scheme variable values in C</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
s7 = s7_init();
|
||
|
|
|
||
|
|
s7_define_variable(s7, "an-integer", s7_make_integer(s7, 1));
|
||
|
|
s7_eval_c_string(s7, "(define (add1 a) (+ a 1))");
|
||
|
|
|
||
|
|
fprintf(stderr, "an-integer: %lld\n",
|
||
|
|
s7_integer(<em class="red">s7_name_to_value</em>(s7, "an-integer")));
|
||
|
|
|
||
|
|
<em class="red">s7_symbol_set_value</em>(s7, <em class="red">s7_make_symbol</em>(s7, "an-integer"), s7_make_integer(s7, 32));
|
||
|
|
|
||
|
|
fprintf(stderr, "now an-integer: %lld\n",
|
||
|
|
s7_integer(<em class="red">s7_name_to_value</em>(s7, "an-integer")));
|
||
|
|
|
||
|
|
fprintf(stderr, "(add1 2): %lld\n",
|
||
|
|
s7_integer(<em class="red">s7_call</em>(s7,
|
||
|
|
s7_name_to_value(s7, "add1"),
|
||
|
|
s7_cons(s7, s7_make_integer(s7, 2), s7_nil(s7)))));
|
||
|
|
}
|
||
|
|
|
||
|
|
/*
|
||
|
|
* doc7
|
||
|
|
* an-integer: 1
|
||
|
|
* now an-integer: 32
|
||
|
|
* (add1 2): 3
|
||
|
|
*/
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>In more complicated cases, it is probably easier use s7_eval_c_string_with_environment.
|
||
|
|
As an example, say we want to have a C procedure that calls the pretty printer function pp
|
||
|
|
in write.scm, returning a string to C. We need to make sure pp is loaded, and catch
|
||
|
|
any errors that come up. And we need to pass the C-level s7 object to pp. So...
|
||
|
|
</p>
|
||
|
|
<pre>static const char *pp(s7_scheme *sc, s7_pointer obj) /* (pp obj) */
|
||
|
|
{
|
||
|
|
return(s7_string(
|
||
|
|
<em class="red">s7_eval_c_string_with_environment</em>(sc,
|
||
|
|
"(catch #t \
|
||
|
|
(lambda () \
|
||
|
|
(unless (defined? 'pp) \
|
||
|
|
(load \"write.scm\")) \
|
||
|
|
(<em class="red">pp</em> obj)) \
|
||
|
|
(lambda (type info) \
|
||
|
|
(apply format #f info)))",
|
||
|
|
<em class="red">s7_inlet</em>(sc, s7_list(sc, 1, s7_cons(sc, s7_make_symbol(sc, "obj"), obj))))));
|
||
|
|
}
|
||
|
|
</pre>
|
||
|
|
<p>and now when we want a pretty-printed representation of something: pp(sc, obj);
|
||
|
|
The s7_inlet call is creating a local environment with the object "obj" bound
|
||
|
|
in scheme to the name "obj" so that (pp obj) will find the "obj" that actually
|
||
|
|
lives in C. You may need to give the full filename for write.scm, or add its path
|
||
|
|
to the <a href="#loadpath">load-path list</a>. In the latter case, <code>(require write.scm)</code> could
|
||
|
|
replace <code>(unless (defined?...))</code>.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="juce"><h4>C++ and Juce, from Rick Taube</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>int main(int argc, const char* argv[])
|
||
|
|
{
|
||
|
|
initialiseJuce_NonGUI();
|
||
|
|
|
||
|
|
s7_scheme *s7 = s7_init();
|
||
|
|
if (!s7)
|
||
|
|
{
|
||
|
|
std::cout << "Can't start S7!\n";
|
||
|
|
return -1;
|
||
|
|
}
|
||
|
|
|
||
|
|
s7_pointer val;
|
||
|
|
std::string str;
|
||
|
|
while (true)
|
||
|
|
{
|
||
|
|
std::cout << "\ns7> ";
|
||
|
|
std::getline(std::cin, str);
|
||
|
|
val = s7_eval_c_string(s7, str.c_str());
|
||
|
|
std::cout << s7_object_to_c_string(s7, val);
|
||
|
|
}
|
||
|
|
|
||
|
|
free(s7);
|
||
|
|
std::cout << "Bye!\n";
|
||
|
|
return 0;
|
||
|
|
}
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="sndlib"><h4>Load sndlib into an s7 repl</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
#include <unistd.h>
|
||
|
|
|
||
|
|
/* assume we've configured and built sndlib, so it has created a mus-config.h file.
|
||
|
|
* also assume we've built s7 with WITH_SYSTEM_EXTRAS set, so we have file-exists? and delete-file
|
||
|
|
*/
|
||
|
|
|
||
|
|
#include "mus-config.h"
|
||
|
|
#include "s7.h"
|
||
|
|
#include "xen.h"
|
||
|
|
#include "clm.h"
|
||
|
|
#include "clm2xen.h"
|
||
|
|
|
||
|
|
/* we need to redirect clm's mus_error calls to s7_error */
|
||
|
|
|
||
|
|
static void mus_error_to_s7(int type, char *msg)
|
||
|
|
{
|
||
|
|
s7_error(s7, /* s7 is declared in xen.h, defined in xen.c */
|
||
|
|
s7_make_symbol(s7, "mus-error"),
|
||
|
|
s7_cons(s7, s7_make_string(s7, msg), s7_nil(s7)));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
|
||
|
|
s7 = s7_init(); /* initialize the interpreter */
|
||
|
|
s7_xen_initialize(s7); /* initialize the xen stuff (hooks and the xen s7 FFI used by sndlib) */
|
||
|
|
Init_sndlib(); /* initialize sndlib with all the functions linked into s7 */
|
||
|
|
|
||
|
|
mus_error_set_handler(mus_error_to_s7); /* catch low-level errors and pass them to s7-error */
|
||
|
|
|
||
|
|
while (1) /* fire up a "repl" */
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> "); /* prompt for input */
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response); /* evaluate input and write the result */
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* gcc -o doc7 doc7.c -lm -I. /usr/local/lib/libsndlib.a -lasound -ldl
|
||
|
|
*
|
||
|
|
* (load "sndlib-ws.scm")
|
||
|
|
* (with-sound () (outa 10 .1))
|
||
|
|
* (load "v.scm")
|
||
|
|
* (with-sound () (fm-violin 0 .1 440 .1))
|
||
|
|
*
|
||
|
|
* you might also need -lgsl -lgslcblas -lfftw3
|
||
|
|
*/
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<p>If you built libsndlib.so, it is possible to use it directly in the s7 repl:
|
||
|
|
</p>
|
||
|
|
<pre>repl ; this is a bare s7 running repl.scm via -DWITH_MAIN=1
|
||
|
|
loading libc_s7.so
|
||
|
|
> (load "/home/bil/test/sndlib/libsndlib.so" (inlet 'init_func 's7_init_sndlib))
|
||
|
|
#t ; s7_init_sndlib ties all the sndlib functions and variables into s7
|
||
|
|
> (load "sndlib-ws.scm")
|
||
|
|
tmpnam
|
||
|
|
> (set! *clm-player* (lambda (file) (system (format #f "sndplay ~A" file))))
|
||
|
|
> (load "v.scm")
|
||
|
|
fm-violin
|
||
|
|
> (with-sound (:play #t) (fm-violin 0 1 440 .1))
|
||
|
|
"test.snd"
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>You can use autoload to load libsndlib when needed:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define (find-library name)
|
||
|
|
(if (or (file-exists? name)
|
||
|
|
(char=? (name 0) #\/))
|
||
|
|
name
|
||
|
|
(call-with-exit
|
||
|
|
(lambda (return)
|
||
|
|
(for-each
|
||
|
|
(lambda (path)
|
||
|
|
(let ((new-name (string-append path "/" name)))
|
||
|
|
(if (file-exists? new-name)
|
||
|
|
(return new-name))))
|
||
|
|
*load-path*)
|
||
|
|
(let ((libs (getenv "LD_LIBRARY_PATH")) ; colon separated directory names
|
||
|
|
(start 0))
|
||
|
|
(do ((colon (char-position #\: libs) (char-position #\: libs start)))
|
||
|
|
((or (not colon)
|
||
|
|
(let ((new-name (string-append (substring libs start colon) "/" name)))
|
||
|
|
(and (file-exists? new-name)
|
||
|
|
(return new-name)))))
|
||
|
|
(set! start (+ colon 1))))
|
||
|
|
name))))
|
||
|
|
|
||
|
|
(<em class="red">autoload</em> 'clm
|
||
|
|
(lambda (e)
|
||
|
|
(load (find-library "libsndlib.so") (inlet '(init_func . s7_init_sndlib)))
|
||
|
|
(set! *features* (cons 'clm *features*))
|
||
|
|
(with-let (rootlet) (define clm #t))
|
||
|
|
(load "sndlib-ws.scm")
|
||
|
|
(set! *clm-player* (lambda (file) (system (format #f "sndplay ~A" file))))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>and use the repl's vt100 stuff to (for example) post the current begin time
|
||
|
|
as a note list computes:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(define (clm-notehook . args)
|
||
|
|
;; assume second arg is begin time (first is instrument name)
|
||
|
|
(when (and (pair? args)
|
||
|
|
(pair? (cdr args))
|
||
|
|
(number? (cadr args)))
|
||
|
|
(with-let (sublet (*repl* 'repl-let) :begin-time (cadr args))
|
||
|
|
(let ((coords (cursor-coords))
|
||
|
|
(col (floor (/ last-col 2))))
|
||
|
|
(let ((str (number->string begin-time)))
|
||
|
|
(format *stderr* "~C[~D;~DH" #\escape prompt-row col)
|
||
|
|
(format *stderr* "~C[K~A" #\escape (if (> (length str) col) (substring str 0 (- col 1)) str)))
|
||
|
|
(format *stderr* "~C[~D;~DH" #\escape (cdr coords) (car coords))))))
|
||
|
|
|
||
|
|
(set! *clm-notehook* clm-notehook)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="pwstype"><h4>Add a new Scheme type and a procedure with a setter</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
/* define *listener-prompt* in scheme, add two accessors for C get/set */
|
||
|
|
|
||
|
|
static const char *listener_prompt(s7_scheme *sc)
|
||
|
|
{
|
||
|
|
return(s7_string(s7_name_to_value(sc, "*listener-prompt*")));
|
||
|
|
}
|
||
|
|
|
||
|
|
static void set_listener_prompt(s7_scheme *sc, const char *new_prompt)
|
||
|
|
{
|
||
|
|
s7_symbol_set_value(sc, s7_make_symbol(sc, "*listener-prompt*"), s7_make_string(sc, new_prompt));
|
||
|
|
}
|
||
|
|
|
||
|
|
/* now add a new type, a struct named "dax" with two fields, a real "x" and a list "data" */
|
||
|
|
/* since the data field is an s7 object, we'll need to mark it to protect it from the GC */
|
||
|
|
|
||
|
|
typedef struct {
|
||
|
|
s7_double x;
|
||
|
|
s7_pointer data;
|
||
|
|
} dax;
|
||
|
|
|
||
|
|
static int dax_type_tag = 0;
|
||
|
|
|
||
|
|
static s7_pointer dax_to_string(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
char *data_str, *str;
|
||
|
|
s7_pointer result;
|
||
|
|
int data_str_len;
|
||
|
|
dax *o = (dax *)s7_c_object_value(s7_car(args));
|
||
|
|
data_str = s7_object_to_c_string(sc, o->data);
|
||
|
|
data_str_len = strlen(data_str);
|
||
|
|
str = (char *)calloc(data_str_len + 32, sizeof(char));
|
||
|
|
snprintf(str, data_str_len + 32, "<dax %.3f %s>", o->x, data_str);
|
||
|
|
free(data_str);
|
||
|
|
result = s7_make_string(sc, str);
|
||
|
|
free(str);
|
||
|
|
return(result);
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer free_dax(s7_scheme *sc, s7_pointer obj)
|
||
|
|
{
|
||
|
|
free(s7_c_object_value(obj));
|
||
|
|
return(NULL);
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer mark_dax(s7_scheme *sc, s7_pointer obj)
|
||
|
|
{
|
||
|
|
dax *o;
|
||
|
|
o = (dax *)s7_c_object_value(obj);
|
||
|
|
s7_mark(o->data);
|
||
|
|
return(NULL);
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer make_dax(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
dax *o;
|
||
|
|
o = (dax *)malloc(sizeof(dax));
|
||
|
|
o->x = s7_real(s7_car(args));
|
||
|
|
if (s7_cdr(args) != s7_nil(sc))
|
||
|
|
o->data = s7_cadr(args);
|
||
|
|
else o->data = s7_nil(sc);
|
||
|
|
return(<em class="red">s7_make_c_object</em>(sc, dax_type_tag, (void *)o));
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer is_dax(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
return(s7_make_boolean(sc,
|
||
|
|
<em class="red">s7_is_c_object</em>(s7_car(args)) &&
|
||
|
|
<em class="red">s7_c_object_type</em>(s7_car(args)) == dax_type_tag));
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer dax_x(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
dax *o;
|
||
|
|
o = (dax *)<em class="red">s7_c_object_value</em>(s7_car(args));
|
||
|
|
return(s7_make_real(sc, o->x));
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer set_dax_x(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
dax *o;
|
||
|
|
o = (dax *)s7_c_object_value(s7_car(args));
|
||
|
|
o->x = s7_real(s7_cadr(args));
|
||
|
|
return(s7_cadr(args));
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer dax_data(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
dax *o;
|
||
|
|
o = (dax *)s7_c_object_value(s7_car(args));
|
||
|
|
return(o->data);
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer set_dax_data(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
dax *o;
|
||
|
|
o = (dax *)s7_c_object_value(s7_car(args));
|
||
|
|
o->data = s7_cadr(args);
|
||
|
|
return(o->data);
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer dax_is_equal(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
s7_pointer p1, p2;
|
||
|
|
dax *d1, *d2;
|
||
|
|
p1 = s7_car(args);
|
||
|
|
p2 = s7_cadr(args);
|
||
|
|
if (p1 == p2)
|
||
|
|
return(s7_t(sc));
|
||
|
|
if ((!s7_is_c_object(p2)) ||
|
||
|
|
(s7_c_object_type(p2) != dax_type_tag))
|
||
|
|
return(s7_f(sc));
|
||
|
|
d1 = (dax *)s7_c_object_value(p1);
|
||
|
|
d2 = (dax *)s7_c_object_value(p2);
|
||
|
|
return(s7_make_boolean(sc,
|
||
|
|
(d1->x == d2->x) &&
|
||
|
|
(s7_is_equal(sc, d1->data, d2->data))));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
|
||
|
|
s7 = s7_init();
|
||
|
|
|
||
|
|
s7_define_variable(s7, "*listener-prompt*", s7_make_string(s7, ">"));
|
||
|
|
|
||
|
|
dax_type_tag = <em class="red">s7_make_c_type</em>(s7, "dax");
|
||
|
|
s7_c_type_set_gc_free(s7, dax_type_tag, free_dax);
|
||
|
|
s7_c_type_set_gc_mark(s7, dax_type_tag, mark_dax);
|
||
|
|
s7_c_type_set_is_equal(s7, dax_type_tag, dax_is_equal);
|
||
|
|
s7_c_type_set_to_string(s7, dax_type_tag, dax_to_string);
|
||
|
|
|
||
|
|
s7_define_function(s7, "make-dax", make_dax, 2, 0, false, "(make-dax x data) makes a new dax");
|
||
|
|
s7_define_function(s7, "dax?", is_dax, 1, 0, false, "(dax? anything) returns #t if its argument is a dax object");
|
||
|
|
|
||
|
|
s7_define_variable(s7, "dax-x",
|
||
|
|
<em class="red">s7_dilambda</em>(s7, "dax-x", dax_x, 1, 0, set_dax_x, 2, 0, "dax x field"));
|
||
|
|
|
||
|
|
s7_define_variable(s7, "dax-data",
|
||
|
|
<em class="red">s7_dilambda</em>(s7, "dax-data", dax_data, 1, 0, set_dax_data, 2, 0, "dax data field"));
|
||
|
|
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n%s ", listener_prompt(s7));
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response); /* evaluate input and write the result */
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* (in Linux);
|
||
|
|
* gcc dax.c -o dax -I. -O2 -g s7.o -ldl -lm -Wl,-export-dynamic -Wno-stringop-overflow
|
||
|
|
* dax
|
||
|
|
* > *listener-prompt*
|
||
|
|
* <em class="gray">">"</em>
|
||
|
|
* > (set! *listener-prompt* ":")
|
||
|
|
* <em class="gray">":"</em>
|
||
|
|
* : (define obj (make-dax 1.0 (list 1 2 3)))
|
||
|
|
* <em class="gray">obj</em>
|
||
|
|
* : obj
|
||
|
|
* <em class="gray">#<dax 1.000 (1 2 3)></em>
|
||
|
|
* : (dax-x obj)
|
||
|
|
* <em class="gray">1.0</em>
|
||
|
|
* : (dax-data obj)
|
||
|
|
* <em class="gray">(1 2 3)</em>
|
||
|
|
* : (set! (dax-x obj) 123.0)
|
||
|
|
* <em class="gray">123.0</em>
|
||
|
|
* : obj
|
||
|
|
* <em class="gray">#<dax 123.000 (1 2 3)></em>
|
||
|
|
* : (dax? obj)
|
||
|
|
* <em class="gray">#t</em>
|
||
|
|
* : (exit)
|
||
|
|
*/
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="functionportexample"><h4>Redirect output (and input) to a C procedure</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static void my_print(s7_scheme *sc, uint8_t c, s7_pointer port)
|
||
|
|
{
|
||
|
|
fprintf(stderr, "[%c] ", c);
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer my_read(s7_scheme *sc, s7_read_t peek, s7_pointer port)
|
||
|
|
{
|
||
|
|
return(<em class="red">s7_make_character</em>(sc, fgetc(stdin)));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
|
||
|
|
s7 = s7_init();
|
||
|
|
|
||
|
|
<em class="red">s7_set_current_output_port</em>(s7, <em class="red">s7_open_output_function</em>(s7, my_print));
|
||
|
|
s7_define_variable(s7, "io-port", <em class="red">s7_open_input_function</em>(s7, my_read));
|
||
|
|
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/*
|
||
|
|
* > (+ 1 2)
|
||
|
|
* <em class="gray">[3]</em>
|
||
|
|
* > (display "hiho")
|
||
|
|
* <em class="gray">[h] [i] [h] [o] [#] [<] [u] [n] [s] [p] [e] [c] [i] [f] [i] [e] [d] [>] </em>
|
||
|
|
* > (define (add1 x) (+ 1 x))
|
||
|
|
* <em class="gray">[a] [d] [d] [1] </em>
|
||
|
|
* > (add1 123)
|
||
|
|
* <em class="gray">[1] [2] [4] </em>
|
||
|
|
* > (read-char io-port)
|
||
|
|
* a ; here I typed "a" in the shell
|
||
|
|
* <em class="gray">[#] [\] [a] </em>
|
||
|
|
*/
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<p>In Snd, we want debug.scm (*debug-port*) output to go to the Snd listener text widget. The Snd function listener_append
|
||
|
|
adds a string to that widget's text, so we define:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">static void (listener_write)(s7_scheme *sc, uint8_t c, s7_pointer port)
|
||
|
|
{
|
||
|
|
char buf[2];
|
||
|
|
buf[0] = c;
|
||
|
|
buf[1] = '\0';
|
||
|
|
listener_append(buf);
|
||
|
|
}
|
||
|
|
</pre>
|
||
|
|
<p>
|
||
|
|
Then we define a Scheme-side variable, *listener-port*, to be a function port:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_define_variable_with_documentation(s7, "*listener-port*",
|
||
|
|
s7_open_output_function(s7, listener_write), "port to write to Snd's listener");
|
||
|
|
</pre>
|
||
|
|
<p>
|
||
|
|
And tie it into *debug-port* via
|
||
|
|
<code>(set! ((funclet trace-in) '*debug-port*) *listener-port*)</code>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="extendop"><h4>Extend a built-in operator ("+" in this case)</h4></div>
|
||
|
|
|
||
|
|
<p>There are several ways to do this. In the first example, we save the original function,
|
||
|
|
and replace it with ours, calling the original whenever possible:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer old_add; /* the original "+" function for non-string cases */
|
||
|
|
static s7_pointer old_string_append; /* same, for "string-append" */
|
||
|
|
|
||
|
|
static s7_pointer our_add(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
/* this will replace the built-in "+" operator, extending it to include strings:
|
||
|
|
* (+ "hi" "ho") -> "hiho" and (+ 3 4) -> 7
|
||
|
|
*/
|
||
|
|
if ((s7_is_pair(args)) &&
|
||
|
|
(s7_is_string(s7_car(args))))
|
||
|
|
return(<em class="red">s7_apply_function</em>(sc, old_string_append, args));
|
||
|
|
return(s7_apply_function(sc, old_add, args));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
s7 = s7_init();
|
||
|
|
|
||
|
|
/* get built-in + and string-append */
|
||
|
|
old_add = s7_name_to_value(s7, "+");
|
||
|
|
old_string_append = s7_name_to_value(s7, "string-append");
|
||
|
|
|
||
|
|
/* redefine "+" */
|
||
|
|
s7_define_function(s7, "+", our_add, 0, 0, true, "(+ ...) adds or appends its arguments");
|
||
|
|
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* > (+ 1 2)
|
||
|
|
* <em class="gray">3</em>
|
||
|
|
* > (+ "hi" "ho")
|
||
|
|
* <em class="gray">"hiho"</em>
|
||
|
|
*/
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
<p>In the next example, we use the method (inlet) machinery:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
#include <math.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer our_abs(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
s7_pointer x;
|
||
|
|
x = s7_car(args);
|
||
|
|
if (!s7_is_number(x))
|
||
|
|
{
|
||
|
|
s7_pointer method;
|
||
|
|
method = <em class="red">s7_method</em>(sc, x, s7_make_symbol(sc, "abs"));
|
||
|
|
if (method == s7_undefined(sc)) /* no method found, so raise an error */
|
||
|
|
s7_wrong_type_arg_error(sc, "abs", 1, x, "a real");
|
||
|
|
return(s7_apply_function(sc, method, args)); /* else apply the method to the args */
|
||
|
|
}
|
||
|
|
return(s7_make_real(sc, (s7_double)fabs(s7_number_to_real(sc, x))));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
|
||
|
|
s7 = s7_init();
|
||
|
|
s7_define_function(s7, "our-abs", our_abs, 1, 0, false, "abs replacement");
|
||
|
|
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* > (our-abs -1)
|
||
|
|
* <em class="gray">1.0</em>
|
||
|
|
* > (our-abs (openlet (inlet 'value -3.0 'abs (lambda (x) (abs (x 'value))))))
|
||
|
|
* <em class="gray">3.0</em>
|
||
|
|
*/
|
||
|
|
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="definestar1"><h4>C-side define* (s7_define_function_star)</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer plus(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
/* (define* (plus (red 32) blue) (+ (* 2 red) blue)) */
|
||
|
|
return(s7_make_integer(sc, 2 * s7_integer(s7_car(args)) + s7_integer(s7_cadr(args))));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
|
||
|
|
s7 = s7_init();
|
||
|
|
<em class="red">s7_define_function_star</em>(s7, "plus", plus, "(red 32) blue", "an example of define* from C");
|
||
|
|
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/*
|
||
|
|
* > (plus 2 3)
|
||
|
|
* <em class="gray">7</em>
|
||
|
|
* > (plus :blue 3)
|
||
|
|
* <em class="gray">67</em>
|
||
|
|
* > (plus :blue 1 :red 4)
|
||
|
|
* <em class="gray">9</em>
|
||
|
|
* > (plus 2 :blue 3)
|
||
|
|
* <em class="gray">7</em>
|
||
|
|
* > (plus :blue 3 :red 1)
|
||
|
|
* <em class="gray">5</em>
|
||
|
|
*/
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="definemacro1"><h4>C-side define-macro (s7_define_macro)</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer plus(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
/* (define-macro (plus a b) `(+ ,a ,b)) */
|
||
|
|
s7_pointer a, b;
|
||
|
|
a = s7_car(args);
|
||
|
|
b = s7_cadr(args);
|
||
|
|
return(s7_list(sc, 3, s7_make_symbol(sc, "+"), a, b));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
|
||
|
|
s7 = s7_init();
|
||
|
|
<em class="red">s7_define_macro</em>(s7, "plus", plus, 2, 0, false, "plus adds its two arguments");
|
||
|
|
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/*
|
||
|
|
* > (plus 2 3)
|
||
|
|
* <em class="gray">5</em>
|
||
|
|
*/
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="definegeneric"><h4>define a generic function in C</h4></div>
|
||
|
|
|
||
|
|
<p>In scheme, a function becomes generic simply by <code>(apply ((car args) 'func) args)</code>.
|
||
|
|
To accomplish the same thing in C, we use s7_method and s7_apply_function:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer plus(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
#define plus_help "(plus obj ...) applies obj's plus method to obj and any trailing arguments."
|
||
|
|
s7_pointer obj, method;
|
||
|
|
obj = s7_car(args);
|
||
|
|
method = <em class="red">s7_method</em>(sc, obj, s7_make_symbol(sc, "plus"));
|
||
|
|
if (s7_is_procedure(method))
|
||
|
|
return(<em class="red">s7_apply_function</em>(sc, method, args));
|
||
|
|
return(s7_f(sc));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
s7 = s7_init();
|
||
|
|
s7_define_function(s7, "plus", plus, 1, 0, true, plus_help);
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* gcc -c s7.c -I.
|
||
|
|
* gcc -o ex15 ex15.c s7.o -I. -lm -ldl
|
||
|
|
*
|
||
|
|
* > (plus 1 2)
|
||
|
|
* <em class="gray">#f</em>
|
||
|
|
* > (define obj (openlet (inlet 'plus (lambda args (apply + 1 (cdr args))))))
|
||
|
|
* <em class="gray">obj</em>
|
||
|
|
* > (plus obj 2 3)
|
||
|
|
* <em class="gray">6</em>
|
||
|
|
*/
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="signal"><h4>Signal handling and continuations</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
#include <signal.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_scheme *s7;
|
||
|
|
struct sigaction new_act, old_act;
|
||
|
|
|
||
|
|
static void handle_sigint(int ignored)
|
||
|
|
{
|
||
|
|
fprintf(stderr, "interrupted!\n");
|
||
|
|
s7_symbol_set_value(s7, s7_make_symbol(s7, "*interrupt*"), <em class="red">s7_make_continuation</em>(s7)); /* save where we were interrupted */
|
||
|
|
sigaction(SIGINT, &new_act, NULL);
|
||
|
|
s7_quit(s7); /* get out of the eval loop if possible */
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer our_sleep(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
/* slow down our infinite loop for demo purposes */
|
||
|
|
sleep(1);
|
||
|
|
return(s7_f(sc));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
|
||
|
|
s7 = s7_init();
|
||
|
|
s7_define_function(s7, "sleep", our_sleep, 0, 0, false, "(sleep) sleeps");
|
||
|
|
s7_define_variable(s7, "*interrupt*", s7_f(s7));
|
||
|
|
/* Scheme variable *interrupt* holds the continuation at the point of the interrupt */
|
||
|
|
|
||
|
|
sigaction(SIGINT, NULL, &old_act);
|
||
|
|
if (old_act.sa_handler != SIG_IGN)
|
||
|
|
{
|
||
|
|
memset(&new_act, 0, sizeof(new_act));
|
||
|
|
new_act.sa_handler = &handle_sigint;
|
||
|
|
sigaction(SIGINT, &new_act, NULL);
|
||
|
|
}
|
||
|
|
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stderr, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/*
|
||
|
|
* > (do ((i 0 (+ i 1))) ((= i -1)) (format () "~D " i) (sleep))
|
||
|
|
* ;;; now type C-C to break out of this loop
|
||
|
|
* 0 1 2 ^Cinterrupted!
|
||
|
|
* ;;; call the continuation to continue from where we were interrupted
|
||
|
|
* > (*interrupt*)
|
||
|
|
* 3 4 5 ^Cinterrupted!
|
||
|
|
* > *interrupt*
|
||
|
|
* #<continuation>
|
||
|
|
* > (+ 1 2)
|
||
|
|
* 3
|
||
|
|
*/
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="notify"><h4>Notification from Scheme that a given Scheme variable has been set</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer scheme_set_notification(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
/* this function is called when the Scheme variable is set! */
|
||
|
|
fprintf(stderr, "%s set to %s\n",
|
||
|
|
s7_object_to_c_string(sc, s7_car(args)),
|
||
|
|
s7_object_to_c_string(sc, s7_cadr(args)));
|
||
|
|
return(s7_cadr(args));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
s7 = s7_init();
|
||
|
|
|
||
|
|
s7_define_function(s7, "notify-C", scheme_set_notification, 2, 0, false, "called if notified-var is set!");
|
||
|
|
s7_define_variable(s7, "notified-var", s7_make_integer(s7, 0));
|
||
|
|
<em class="red">s7_set_setter</em>(s7, s7_make_symbol(s7, "notified-var"), s7_name_to_value(s7, "notify-C"));
|
||
|
|
|
||
|
|
if (argc == 2)
|
||
|
|
{
|
||
|
|
fprintf(stderr, "load %s\n", argv[1]);
|
||
|
|
if (!s7_load(s7, argv[1]))
|
||
|
|
fprintf(stderr, "can't find %s\n", argv[1]);
|
||
|
|
}
|
||
|
|
else
|
||
|
|
{
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* > notified-var
|
||
|
|
* <em class="gray">0</em>
|
||
|
|
* > (set! notified-var 32)
|
||
|
|
* <em class="gray">notified-var set to 32</em>
|
||
|
|
* <em class="gray">32</em>
|
||
|
|
*/
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="namespace"><h4>Load C defined stuff into a separate namespace</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer func1(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
return(s7_make_integer(sc, s7_integer(s7_car(args)) + 1));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
s7_pointer new_env;
|
||
|
|
|
||
|
|
s7 = s7_init();
|
||
|
|
|
||
|
|
/* "func1" and "var1" will be placed in an anonymous environment,
|
||
|
|
* accessible from Scheme via the global variable "lib-exports"
|
||
|
|
*/
|
||
|
|
|
||
|
|
new_env = <em class="red">s7_inlet</em>(s7, s7_curlet(s7), s7_nil(s7));
|
||
|
|
/* make a private environment for func1 and var1 below (this is our "namespace") */
|
||
|
|
s7_gc_protect(s7, new_env);
|
||
|
|
|
||
|
|
s7_define(s7, <em class="red">new_env</em>,
|
||
|
|
s7_make_symbol(s7, "func1"),
|
||
|
|
<em class="red">s7_make_function</em>(s7, "func1", func1, 1, 0, false, "func1 adds 1 to its argument"));
|
||
|
|
|
||
|
|
s7_define(s7, <em class="red">new_env</em>, s7_make_symbol(s7, "var1"), s7_make_integer(s7, 32));
|
||
|
|
/* those two symbols are now defined in the new environment */
|
||
|
|
|
||
|
|
/* add "lib-exports" to the global environment */
|
||
|
|
s7_define_variable(s7, "lib-exports", <em class="red">s7_let_to_list</em>(s7, new_env));
|
||
|
|
|
||
|
|
if (argc == 2)
|
||
|
|
{
|
||
|
|
fprintf(stderr, "load %s\n", argv[1]);
|
||
|
|
if (!s7_load(s7, argv[1]))
|
||
|
|
fprintf(stderr, "can't find %s\n", argv[1]);
|
||
|
|
}
|
||
|
|
else
|
||
|
|
{
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* > func1
|
||
|
|
* <em class="gray">;func1: unbound variable, line 1</em>
|
||
|
|
* > lib-exports
|
||
|
|
* <em class="gray">((var1 . 32) (func1 . func1))</em>
|
||
|
|
* ;; so lib-exports has the C-defined names and values
|
||
|
|
* ;; we can use these directly:
|
||
|
|
*
|
||
|
|
* > (define lib-env (apply <em class="red">sublet</em> (curlet) lib-exports))
|
||
|
|
* <em class="gray">lib-env</em>
|
||
|
|
* > (<em class="red">with-let</em> lib-env (func1 var1))
|
||
|
|
* <em class="gray">33</em>
|
||
|
|
*
|
||
|
|
* ;; or rename them to prepend "lib:"
|
||
|
|
* > (define lib-env (apply sublet
|
||
|
|
(curlet)
|
||
|
|
(map (lambda (binding)
|
||
|
|
(cons (string->symbol
|
||
|
|
(string-append "lib:" (symbol->string (car binding))))
|
||
|
|
(cdr binding)))
|
||
|
|
lib-exports)))
|
||
|
|
* <em class="gray">lib-env</em>
|
||
|
|
* > (with-let lib-env (lib:func1 lib:var1))
|
||
|
|
* <em class="gray">33</em>
|
||
|
|
*
|
||
|
|
* ;;; now for convenience, place "func1" in the global environment under the name "func2"
|
||
|
|
* > (define func2 (cdadr lib-exports))
|
||
|
|
* <em class="gray">func2</em>
|
||
|
|
* > (func2 1)
|
||
|
|
* <em class="gray">2</em>
|
||
|
|
*/
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="Cerrors"><h4>Handle scheme errors in C</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer error_handler(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "error: %s\n", s7_string(s7_car(args)));
|
||
|
|
return(s7_f(sc));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
bool with_error_hook = false;
|
||
|
|
|
||
|
|
s7 = s7_init();
|
||
|
|
s7_define_function(s7, "error-handler", error_handler, 1, 0, false, "our error handler");
|
||
|
|
|
||
|
|
if (with_error_hook)
|
||
|
|
s7_eval_c_string(s7, "(set! (hook-functions *error-hook*) \n\
|
||
|
|
(list (lambda (hook) \n\
|
||
|
|
(error-handler \n\
|
||
|
|
(apply format #f (hook 'data))) \n\
|
||
|
|
(set! (hook 'result) 'our-error))))");
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
s7_pointer old_port, result;
|
||
|
|
int gc_loc = -1;
|
||
|
|
const char *errmsg = NULL;
|
||
|
|
|
||
|
|
/* trap error messages */
|
||
|
|
old_port = s7_set_current_error_port(s7, s7_open_output_string(s7));
|
||
|
|
if (old_port != s7_nil(s7))
|
||
|
|
gc_loc = s7_gc_protect(s7, old_port);
|
||
|
|
|
||
|
|
/* evaluate the input string */
|
||
|
|
result = s7_eval_c_string(s7, buffer);
|
||
|
|
|
||
|
|
/* print out the value wrapped in "{}" so we can tell it from other IO paths */
|
||
|
|
fprintf(stdout, "{%s}", s7_object_to_c_string(s7, result));
|
||
|
|
|
||
|
|
/* look for error messages */
|
||
|
|
errmsg = s7_get_output_string(s7, s7_current_error_port(s7));
|
||
|
|
|
||
|
|
/* if we got something, wrap it in "[]" */
|
||
|
|
if ((errmsg) && (*errmsg))
|
||
|
|
fprintf(stdout, "[%s]", errmsg);
|
||
|
|
|
||
|
|
s7_close_output_port(s7, s7_current_error_port(s7));
|
||
|
|
s7_set_current_error_port(s7, old_port);
|
||
|
|
if (gc_loc != -1)
|
||
|
|
s7_gc_unprotect_at(s7, gc_loc);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/*
|
||
|
|
* gcc -c s7.c -I. -g3
|
||
|
|
* gcc -o ex3 ex3.c s7.o -lm -I. -ldl
|
||
|
|
*
|
||
|
|
* if with_error_hook is false,
|
||
|
|
*
|
||
|
|
* > (+ 1 2)
|
||
|
|
* <em class="gray">{3}</em>
|
||
|
|
* > (+ 1 #\c)
|
||
|
|
* <em class="gray">{wrong-type-arg}[</em>
|
||
|
|
* <em class="gray">;+ argument 2, #\c, is character but should be a number, line 1</em>
|
||
|
|
* ]
|
||
|
|
*
|
||
|
|
* so s7 by default prepends ";" to the error message, and appends "\n",
|
||
|
|
* sending that to current-error-port, and the error type ('wrong-type-arg here)
|
||
|
|
* is returned.
|
||
|
|
*
|
||
|
|
* if with_error_hook is true,
|
||
|
|
*
|
||
|
|
* > (+ 1 2)
|
||
|
|
* <em class="gray">{3}</em>
|
||
|
|
* > (+ 1 #\c)
|
||
|
|
* <em class="red">error</em><em class="gray">: + argument 2, #\c, is character but should be a number</em>
|
||
|
|
* <em class="gray">{our-error}</em>
|
||
|
|
*
|
||
|
|
* so now the *error-hook* code handles both the error reporting and
|
||
|
|
* the value returned ('our-error in this case).
|
||
|
|
*/
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="testhook"><h4>C and Scheme hooks</h4></div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer my_hook_function(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
fprintf(stderr, "a is %s\n", s7_object_to_c_string(sc, s7_symbol_local_value(sc, s7_make_symbol(sc, "a"), s7_car(args))));
|
||
|
|
return(s7_car(args));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
s7_pointer test_hook;
|
||
|
|
|
||
|
|
s7 = s7_init();
|
||
|
|
|
||
|
|
/* define test_hook in C, test-hook in Scheme, arguments are named a and b */
|
||
|
|
test_hook = <em class="red">s7_eval_c_string</em>(s7, "(make-hook 'a 'b)");
|
||
|
|
s7_define_constant(s7, "test-hook", test_hook);
|
||
|
|
|
||
|
|
/* add my_hook_function to the test_hook function list */
|
||
|
|
<em class="red">s7_hook_set_functions</em>(s7, test_hook,
|
||
|
|
s7_cons(s7,
|
||
|
|
s7_make_function(s7, "my-hook-function", my_hook_function, 1, 0, false, "my hook-function"),
|
||
|
|
s7_hook_functions(s7, test_hook)));
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/*
|
||
|
|
* > test-hook
|
||
|
|
* <em class="gray">#<lambda (hook)></em>
|
||
|
|
* > (hook-functions test-hook)
|
||
|
|
* <em class="gray">(my-hook-function)</em>
|
||
|
|
* > (test-hook 1 2)
|
||
|
|
* <em class="gray">a is 1</em>
|
||
|
|
* <em class="gray">#<unspecified></em>
|
||
|
|
*/
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="dload"><h4>Load a shared library</h4></div>
|
||
|
|
|
||
|
|
<p>We can use dlopen to load a shared library, and dlsym to initialize
|
||
|
|
that library in our main program. The tricky part is to conjure up the right
|
||
|
|
compiler and loader flags.
|
||
|
|
First we define a module that defines a new s7 function, add-1 that we'll tie
|
||
|
|
into s7 explicitly, and another
|
||
|
|
function that we'll try to call by waving a wand.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
double a_function(double an_arg);
|
||
|
|
double a_function(double an_arg)
|
||
|
|
{
|
||
|
|
return(an_arg + 1.0);
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer add_1(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
return(s7_make_integer(sc, s7_integer(s7_car(args)) + 1));
|
||
|
|
}
|
||
|
|
|
||
|
|
void init_ex(s7_scheme *sc);
|
||
|
|
void init_ex(s7_scheme *sc) /* this needs to be globally accessible (not "static") */
|
||
|
|
{
|
||
|
|
/* tell s7 about add-1, but leave a_function hidden */
|
||
|
|
s7_define_function(sc, "add-1", add_1, 1, 0, false, "(add-1 x) adds 1 to x");
|
||
|
|
}
|
||
|
|
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
|
||
|
|
<p>And here is our main program:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
#include <dlfcn.h>
|
||
|
|
|
||
|
|
static void *library = NULL;
|
||
|
|
|
||
|
|
static s7_pointer try(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
/* try tries to call an arbitrary function in the shared library */
|
||
|
|
void *func;
|
||
|
|
func = <em class="red">dlsym</em>(library, s7_string(s7_car(args)));
|
||
|
|
if (func)
|
||
|
|
{
|
||
|
|
/* we'll assume double f(double) */
|
||
|
|
typedef double (*dl_func)(double arg);
|
||
|
|
return(s7_make_real(sc, ((dl_func)<em class="red">func</em>)(s7_real(s7_cadr(args)))));
|
||
|
|
}
|
||
|
|
return(s7_error(sc, s7_make_symbol(sc, "can't find function"),
|
||
|
|
s7_list(sc, 2, s7_make_string(sc, "loader error: ~S"),
|
||
|
|
s7_make_string(sc, dlerror()))));
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_pointer cload(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
/* cload loads a shared library */
|
||
|
|
#define CLOAD_HELP "(cload so-file-name) loads the module"
|
||
|
|
library = dlopen(s7_string(s7_car(args)), RTLD_LAZY);
|
||
|
|
if (library)
|
||
|
|
{
|
||
|
|
/* call our init func to define add-1 in s7 */
|
||
|
|
void *init_func;
|
||
|
|
init_func = <em class="red">dlsym</em>(library, s7_string(s7_cadr(args)));
|
||
|
|
if (init_func)
|
||
|
|
{
|
||
|
|
typedef void *(*dl_func)(s7_scheme *sc);
|
||
|
|
((dl_func)<em class="red">init_func</em>)(sc); /* call the initialization function (init_ex above) */
|
||
|
|
return(s7_t(sc));
|
||
|
|
}
|
||
|
|
}
|
||
|
|
return(s7_error(sc, s7_make_symbol(sc, "load-error"),
|
||
|
|
s7_list(sc, 2, s7_make_string(sc, "loader error: ~S"),
|
||
|
|
s7_make_string(sc, dlerror()))));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
s7_scheme *s7;
|
||
|
|
|
||
|
|
s7 = s7_init();
|
||
|
|
|
||
|
|
s7_define_function(s7, "cload", cload, 2, 0, false, CLOAD_HELP);
|
||
|
|
s7_define_function(s7, "try", try, 2, 0, false,
|
||
|
|
"(try name num) tries to call name in the shared library with the argument num.");
|
||
|
|
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/* Put the module in the file ex3a.c and the main program in ex3.c, then
|
||
|
|
*
|
||
|
|
* in Linux:
|
||
|
|
* gcc -c -fPIC ex3a.c
|
||
|
|
* gcc ex3a.o -shared -o ex3a.so
|
||
|
|
* gcc -c s7.c -I. -fPIC -shared
|
||
|
|
* gcc -o ex3 ex3.c s7.o -lm -ldl -I. -Wl,-export-dynamic
|
||
|
|
* # omit -ldl in freeBSD, openBSD might want -ftrampolines
|
||
|
|
*
|
||
|
|
* in Mac OSX:
|
||
|
|
* gcc -c ex3a.c
|
||
|
|
* gcc ex3a.o -o ex3a.so -dynamic -bundle -undefined suppress -flat_namespace
|
||
|
|
* gcc -c s7.c -I. -dynamic -bundle -undefined suppress -flat_namespace
|
||
|
|
* gcc -o ex3 ex3.c s7.o -lm -ldl -I.
|
||
|
|
*
|
||
|
|
* and run it:
|
||
|
|
* ex3
|
||
|
|
* > (cload "/home/bil/snd-18/ex3a.so" "init_ex")
|
||
|
|
* <em class="gray">#t</em>
|
||
|
|
* > (add-1 2)
|
||
|
|
* <em class="gray">3</em>
|
||
|
|
* > (try "a_function" 2.5)
|
||
|
|
* <em class="gray">3.5</em>
|
||
|
|
*/
|
||
|
|
</pre></div>
|
||
|
|
|
||
|
|
<p>All of this is just boring boilerplate, so with a little support from s7,
|
||
|
|
we can write a script to do the entire linkage. The s7 side is an extension
|
||
|
|
to "load" that loads a shared object file if its extension is "so", and
|
||
|
|
runs an initialization function whose name is defined in the load
|
||
|
|
environment (the optional second argument to load). An example of the scheme side is cload.scm,
|
||
|
|
included in the s7 tarball. It defines a function that can be
|
||
|
|
called:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(c-define '(double j0 (double)) "m" "math.h")
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>This links the s7 function m:j0 to the math library
|
||
|
|
function j0. See <a href="#cload">cload.scm</a> for more details.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<p>Here's a shorter example:
|
||
|
|
</p>
|
||
|
|
<div class="indented">
|
||
|
|
<pre>add1.c:
|
||
|
|
|
||
|
|
#include <stdlib.h>
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer add1(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
if (s7_is_integer(s7_car(args)))
|
||
|
|
return(s7_make_integer(sc, 1 + s7_integer(s7_car(args))));
|
||
|
|
return(s7_wrong_type_arg_error(sc, "add1", 1, s7_car(args), "an integer"));
|
||
|
|
}
|
||
|
|
|
||
|
|
void add1_init(s7_scheme *sc);
|
||
|
|
void add1_init(s7_scheme *sc)
|
||
|
|
{
|
||
|
|
s7_define_function(sc, "add1", add1, 1, 0, false, "(add1 int) adds 1 to int");
|
||
|
|
}
|
||
|
|
|
||
|
|
/* gcc -fpic -c add1.c
|
||
|
|
* gcc -shared -Wl,-soname,libadd1.so -o libadd1.so add1.o -lm -lc
|
||
|
|
* gcc s7.c -o repl -fpic -DWITH_MAIN -I. -ldl -lm -Wl,-export-dynamic -DUSE_SND=0
|
||
|
|
* repl
|
||
|
|
* (load "libadd1.so" (inlet 'init_func 'add1_init))
|
||
|
|
* (add1 2)
|
||
|
|
*/
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="gmpex"><h4>Bignums in C</h4></div>
|
||
|
|
|
||
|
|
<p>Bignum support depends on gmp, mpfr, and mpc. In this example, we define "add-1" which adds
|
||
|
|
1 to any kind of number. The s7_big_* functions return the underlying gmp/mpfr/mpc pointer.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>#include <stdlib.h>
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <string.h>
|
||
|
|
|
||
|
|
#include <gmp.h>
|
||
|
|
#include <mpfr.h>
|
||
|
|
#include <mpc.h>
|
||
|
|
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer big_add_1(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
/* add 1 to either a normal number or a bignum */
|
||
|
|
s7_pointer x, n;
|
||
|
|
x = s7_car(args);
|
||
|
|
if (s7_is_big_integer(x))
|
||
|
|
{
|
||
|
|
mpz_t big_n;
|
||
|
|
mpz_init_set(big_n, *s7_big_integer(x));
|
||
|
|
mpz_add_ui(big_n, big_n, 1);
|
||
|
|
n = s7_make_big_integer(sc, &big_n);
|
||
|
|
mpz_clear(big_n);
|
||
|
|
return(n);
|
||
|
|
}
|
||
|
|
if (s7_is_big_ratio(x))
|
||
|
|
{
|
||
|
|
mpq_t big_q;
|
||
|
|
mpq_init(big_q);
|
||
|
|
mpq_set_si(big_q, 1, 1);
|
||
|
|
mpq_add(big_q, *s7_big_ratio(x), big_q);
|
||
|
|
mpq_canonicalize(big_q);
|
||
|
|
n = s7_make_big_ratio(sc, &big_q);
|
||
|
|
mpq_clear(big_q);
|
||
|
|
return(n);
|
||
|
|
}
|
||
|
|
if (s7_is_big_real(x))
|
||
|
|
{
|
||
|
|
mpfr_t big_x;
|
||
|
|
mpfr_init_set(big_x, *s7_big_real(x), MPFR_RNDN);
|
||
|
|
mpfr_add_ui(big_x, big_x, 1, MPFR_RNDN);
|
||
|
|
n = s7_make_big_real(sc, &big_x);
|
||
|
|
mpfr_clear(big_x);
|
||
|
|
return(n);
|
||
|
|
}
|
||
|
|
if (s7_is_big_complex(x))
|
||
|
|
{
|
||
|
|
mpc_t big_z;
|
||
|
|
mpc_init2(big_z, mpc_get_prec(*s7_big_complex(x)));
|
||
|
|
mpc_add_ui(big_z, *s7_big_complex(x), 1, MPC_RNDNN);
|
||
|
|
n = s7_make_big_complex(sc, &big_z);
|
||
|
|
mpc_clear(big_z);
|
||
|
|
return(n);
|
||
|
|
}
|
||
|
|
if (s7_is_integer(x))
|
||
|
|
return(s7_make_integer(sc, 1 + s7_integer(x)));
|
||
|
|
if (s7_is_rational(x))
|
||
|
|
return(s7_make_ratio(sc, s7_numerator(x) + s7_denominator(x), s7_denominator(x)));
|
||
|
|
if (s7_is_real(x))
|
||
|
|
return(s7_make_real(sc, 1.0 + s7_real(x)));
|
||
|
|
if (s7_is_complex(x))
|
||
|
|
return(s7_make_complex(sc, 1.0 + s7_real_part(x), s7_imag_part(x)));
|
||
|
|
return(s7_wrong_type_arg_error(sc, "add-1", 0, x, "a number"));
|
||
|
|
}
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *s7;
|
||
|
|
char buffer[512];
|
||
|
|
char response[1024];
|
||
|
|
|
||
|
|
s7 = s7_init();
|
||
|
|
s7_define_function(s7, "add-1", big_add_1, 1, 0, false, "(add-1 num) adds 1 to num");
|
||
|
|
|
||
|
|
while (1)
|
||
|
|
{
|
||
|
|
fprintf(stdout, "\n> ");
|
||
|
|
fgets(buffer, 512, stdin);
|
||
|
|
if ((buffer[0] != '\n') ||
|
||
|
|
(strlen(buffer) > 1))
|
||
|
|
{
|
||
|
|
snprintf(response, 1024, "(write %s)", buffer);
|
||
|
|
s7_eval_c_string(s7, response);
|
||
|
|
}
|
||
|
|
}
|
||
|
|
}
|
||
|
|
|
||
|
|
/*
|
||
|
|
* gcc -DWITH_GMP=1 -c s7.c -I. -O2 -g3
|
||
|
|
* gcc -DWITH_GMP=1 -o gmpex gmpex.c s7.o -I. -O2 -lm -ldl -lgmp -lmpfr -lmpc
|
||
|
|
*
|
||
|
|
* gmpex
|
||
|
|
* > (add-1 1)
|
||
|
|
* 2
|
||
|
|
* > (add-1 2/3)
|
||
|
|
* 5/3
|
||
|
|
* > (add-1 1.4)
|
||
|
|
* 2.4
|
||
|
|
* > (add-1 1.5+i)
|
||
|
|
* 2.5+1i
|
||
|
|
* > (add-1 (bignum 3))
|
||
|
|
* 4
|
||
|
|
* > (add-1 (bignum 3/4))
|
||
|
|
* 7/4
|
||
|
|
* > (add-1 (bignum 2.5))
|
||
|
|
* 3.500E0
|
||
|
|
* > (add-1 (bignum 1.5+i))
|
||
|
|
* 2.500E0+1.000E0i
|
||
|
|
*/
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<p>To tie mpfr's bessel-j0 into s7 at run-time:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="indented">
|
||
|
|
<pre>/* libgmp_s7.c */
|
||
|
|
|
||
|
|
#include <gmp.h>
|
||
|
|
#include <mpfr.h>
|
||
|
|
#include <mpc.h>
|
||
|
|
|
||
|
|
#define WITH_GMP 1
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer gmp_bessel_j0(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
s7_pointer x, result;
|
||
|
|
mpfr_t mp;
|
||
|
|
|
||
|
|
mpfr_init2(mp, s7_integer(s7_let_field_ref(sc, s7_make_symbol(sc, "bignum-precision"))));
|
||
|
|
/* initialize the mpfr variable mp to the current s7 bignum-precision */
|
||
|
|
|
||
|
|
x = s7_car(args);
|
||
|
|
if (s7_is_big_real(x))
|
||
|
|
<em class="red">mpfr_j0</em>(mp, *s7_big_real(x), MPFR_RNDN);
|
||
|
|
else
|
||
|
|
{
|
||
|
|
if (s7_is_real(x))
|
||
|
|
{
|
||
|
|
mpfr_set_d(mp, s7_real(x), MPFR_RNDN);
|
||
|
|
<em class="red">mpfr_j0</em>(mp, mp, MPFR_RNDN);
|
||
|
|
}
|
||
|
|
else return(s7_wrong_type_arg_error(sc, "gmp_bessel_j0", 1, x, "real"));
|
||
|
|
}
|
||
|
|
|
||
|
|
result = s7_make_big_real(sc, &mp);
|
||
|
|
mpfr_clear(mp);
|
||
|
|
return(result);
|
||
|
|
}
|
||
|
|
|
||
|
|
void libgmp_s7_init(s7_scheme *sc);
|
||
|
|
void libgmp_s7_init(s7_scheme *sc)
|
||
|
|
{
|
||
|
|
s7_define_function(sc, "bessel-j0", gmp_bessel_j0, 1, 0, false, "(bessel-j0 x) returns j0(x)");
|
||
|
|
}
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<p>libarb_s7.c provides some extensions of the multiprecision math: Bessel functions and the like. It is based on
|
||
|
|
the Flint and Arb libraries, flintlib.org and arblib.org. In Linux:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">gcc -fPIC -c libarb_s7.c
|
||
|
|
gcc libarb_s7.o -shared -o libarb_s7.so -lflint -larb
|
||
|
|
repl
|
||
|
|
> (load "libarb_s7.so" (inlet 'init_func 'libarb_s7_init))
|
||
|
|
<em class="gray">#f</em>
|
||
|
|
> (acb_bessel_j 0 1.0)
|
||
|
|
<em class="gray">7.651976865579665514497175261026632209096E-1</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="gdb"><h4>gdb</h4></div>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
gdbinit has some debugging commands, intended for your ~/.gdbinit file.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">s7print interprets its argument as an s7 value and displays it
|
||
|
|
s7eval evals its argument (a string)
|
||
|
|
s7stack displays the current s7 stack (nested lets)
|
||
|
|
s7value prints the value of the variable passed by its print name: s7v "*features*"
|
||
|
|
s7let shows all non-global variables that are currently accessible
|
||
|
|
s7history shows the history entries (if enabled)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>gdbinit also has two backtrace
|
||
|
|
decoders: s7bt and s7btfull. The bt replacements print the gdb backtrace info,
|
||
|
|
replacing bare pointer numbers with their s7 value, wherever possible:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(gdb) s7bt
|
||
|
|
#0 0x000055555567f7ca in check_cell (p=<b>#<lambda (lst ind)></b>,
|
||
|
|
func=0x5555559106e0 <__FUNCTION__.10273> "mark_slot", line=3976) at s7.c:28494
|
||
|
|
#1 0x000055555567f84d in check_nref (p=<b>#<lambda (lst ind)></b>,
|
||
|
|
func=0x5555559106e0 <__FUNCTION__.10273> "mark_slot", line=3976) at s7.c:28507
|
||
|
|
#2 0x0000555555563201 in mark_slot (p=<b>'list-ref #<lambda (lst ind)></b>) at s7.c:3976
|
||
|
|
#3 0x0000555555564ce0 in mark_let (env=<b>#<mock-number-class></b>) at s7.c:4506
|
||
|
|
#4 0x0000555555563239 in mark_slot (p=<b>'mock-number-class #<mock-number-class></b>) at s7.c:3976
|
||
|
|
#5 0x0000555555564ce0 in mark_let (env=<b>(inlet 'mock-number-class #<mock-number-class> 'mock-number mock-number)</b>) at s7.c:4506
|
||
|
|
#6 0x0000555555563239 in mark_slot (p=<b>'*mock-number* (inlet 'mock-number-class #<mock-number-class> 'mock-number...)</b>) at s7.c:3976
|
||
|
|
#7 0x0000555555564ce0 in mark_let (env=<b>(inlet '*features* (mockery.scm stuff.scm linux autoload dlopen...))</b>) at s7.c:4506
|
||
|
|
#8 0x0000555555565697 in mark_closure (p=<b>reactive-vector</b>) at s7.c:4590
|
||
|
|
#9 0x0000555555566872 in mark_rootlet (sc=0x555555b41eb0) at s7.c:4813
|
||
|
|
#10 0x0000555555566a2f in gc (sc=0x555555b41eb0) at s7.c:4897
|
||
|
|
#11 0x000055555558e903 in copy_stack (sc=0x555555b41eb0, old_v=<b>[sc->stack] #<stack></b>) at s7.c:9024
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="ffinotes"><h4>FFI notes</h4></div>
|
||
|
|
|
||
|
|
<ul>
|
||
|
|
<li><a href="#cerrors">Errors</a>
|
||
|
|
</li><li><a href="#cgcprotection">GC protection</a>
|
||
|
|
</li><li><a href="#ccload">Load</a>
|
||
|
|
</li><li><a href="#cevalapply">Eval and Apply</a>
|
||
|
|
</li><li><a href="#cdefine">Define</a>
|
||
|
|
</li><li><a href="#cfunctioninfo">Function info</a>
|
||
|
|
</li><li><a href="#ccobjects">C-objects</a>
|
||
|
|
</li><li><a href="#cio">IO</a>
|
||
|
|
</li><li><a href="#clets">Lets</a>
|
||
|
|
</li><li><a href="#csymbols">Symbols</a>
|
||
|
|
</li><li><a href="#cnumbers">Numbers</a>
|
||
|
|
</li><li><a href="#clists">Lists</a>
|
||
|
|
</li><li><a href="#cvectors">Vectors</a>
|
||
|
|
</li><li><a href="#ccpointers">C-pointers</a>
|
||
|
|
</li><li><a href="#cstrings">Strings</a>
|
||
|
|
</li><li><a href="#ccharacters">Characters</a>
|
||
|
|
</li><li><a href="#chashtables">Hash-tables</a>
|
||
|
|
</li><li><a href="#citerators">Iterators</a>
|
||
|
|
</li><li><a href="#chooks">Hooks</a>
|
||
|
|
</li><li><a href="#cconstants">Constants</a>
|
||
|
|
</li><li><a href="#coptimizations">Optimization</a>
|
||
|
|
</li><li><a href="#candsoon">And so on...</a>
|
||
|
|
</li></ul>
|
||
|
|
|
||
|
|
<div class="shortheader" id="cerrors">Errors</div>
|
||
|
|
|
||
|
|
<p>Most of the s7.h functions do little, if any, error checking. s7_car, for example,
|
||
|
|
does not check that its argument is a pair. Partly this is a matter of speed; partly
|
||
|
|
of simplicity. If we had elaborate error checks, we'd need some convention
|
||
|
|
for passing error information back to the caller, and of course separate versions
|
||
|
|
of each function for cases where all those checks are redundant. You can easily
|
||
|
|
make your own C version of s7_car that includes error checks:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">static s7_pointer my_car(s7_scheme *sc, s7_pointer lst)
|
||
|
|
{
|
||
|
|
if (s7_is_pair(lst))
|
||
|
|
return(s7_car(lst));
|
||
|
|
return(<em class="red">s7_wrong_type_arg_error</em>(sc, "my_car", 0, "a pair"));
|
||
|
|
}
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The s7.h error functions are:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">s7_pointer s7_error(s7_scheme *sc, s7_pointer type, s7_pointer info);
|
||
|
|
|
||
|
|
s7_pointer s7_wrong_type_arg_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr);
|
||
|
|
s7_pointer s7_out_of_range_error(s7_scheme *sc, const char *caller, s7_int arg_n, s7_pointer arg, const char *descr);
|
||
|
|
s7_pointer s7_wrong_number_of_args_error(s7_scheme *sc, const char *caller, s7_pointer args);
|
||
|
|
|
||
|
|
s7_pointer s7_current_error_port(s7_scheme *sc);
|
||
|
|
s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port);
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>s7_error is equivalent to the scheme error function, and like the latter, it takes two arguments:
|
||
|
|
a symbol giving the error type, and a list giving the error data. In s7, all of the data lists
|
||
|
|
are organized so that you can <code>(apply format #f data)</code> to get an error string.
|
||
|
|
If you're using catch to handle errors, the error type is what catch looks for. So, the
|
||
|
|
s7_wrong_type_arg call above could be:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_error(sc, s7_make_symbol(sc, "wrong-type-arg"),
|
||
|
|
s7_list(sc, 3, s7_make_string(sc, "~S is a ~S, but should be a pair"),
|
||
|
|
s7_car(lst),
|
||
|
|
s7_type_of(sc, s7_car(lst))));
|
||
|
|
</pre>
|
||
|
|
<p>s7_wrong_type_arg_error takes the name of the caller, the argument number, the argument itself,
|
||
|
|
and a description of the type expected. If the argument number is 0, that info is left out of the
|
||
|
|
error message (that is, the caller takes only one argument). s7_out_of_range_error is similar.
|
||
|
|
s7_wrong_number_of_args_error takes the caller's name and the offending arg list. The corresponding
|
||
|
|
error types are 'wrong-type-arg, 'wrong-number-of-args, and 'out-of-range.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Normally, s7_error sends its error message
|
||
|
|
to the current error-port which defaults to stderr. In GUI-based apps,
|
||
|
|
you may need to redirect the output to your interface. One method,
|
||
|
|
used in Snd's snd-motif.c, captures the error output in an output string:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">old_port = s7_set_current_error_port(s7, s7_open_output_string(s7));
|
||
|
|
...
|
||
|
|
result = s7_eval_c_string(s7, text);
|
||
|
|
errmsg = s7_get_output_string(s7, s7_current_error_port(s7));
|
||
|
|
s7_close_output_port(s7, s7_current_error_port(s7));
|
||
|
|
s7_set_current_error_port(s7, old_port);
|
||
|
|
...
|
||
|
|
</pre>
|
||
|
|
<p>and if errmsg is not NULL, it posts it somewhere.
|
||
|
|
(You'll also want to GC-protect the old port while it is idle).
|
||
|
|
If you don't want catch or s7's error messages, you can go down
|
||
|
|
a level via *error-hook*.
|
||
|
|
</p>
|
||
|
|
<p>s7_error does not return; its s7_pointer return type is just a convenience. It unwinds the
|
||
|
|
scheme stack, closing files, handling dynamic-winds, looking for a catch that matches its type argument
|
||
|
|
and so on, then longjmps to unwind the C stack. If a catch is found, its error handler becomes the new point
|
||
|
|
of execution.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="cgcprotection">GC protection</div>
|
||
|
|
|
||
|
|
<p>If you save an s7_pointer value in C, you may need to protect it from the garbage collector. In the example above,
|
||
|
|
the first "..." is:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">gc_loc = s7_gc_protect(s7, old_port);
|
||
|
|
</pre>
|
||
|
|
<p>where gc_loc is (or should be) an s7_int. Since we're subsequently
|
||
|
|
calling s7_eval_c_string, we need to GC protect old_port beforehand. After the evaluation,
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_close_output_port(s7, s7_current_error_port(s7));
|
||
|
|
s7_set_current_error_port(s7, old_port);
|
||
|
|
s7_gc_unprotect_at(s7, gc_loc);
|
||
|
|
</pre>
|
||
|
|
<p>The full set of GC protection functions is:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_int s7_gc_protect(s7_scheme *sc, s7_pointer x);
|
||
|
|
void s7_gc_unprotect_at(s7_scheme *sc, s7_int loc);
|
||
|
|
s7_pointer s7_gc_protected_at(s7_scheme *sc, s7_int loc);
|
||
|
|
|
||
|
|
s7_pointer s7_gc_protect_via_stack(s7_scheme *sc, s7_pointer x);
|
||
|
|
s7_pointer s7_gc_unprotect_via_stack(s7_scheme *sc, s7_pointer x);
|
||
|
|
|
||
|
|
s7_pointer s7_gc_protect_via_location(s7_scheme *sc, s7_pointer x, s7_int loc);
|
||
|
|
s7_pointer s7_gc_unprotect_via_location(s7_scheme *sc, s7_int loc);
|
||
|
|
|
||
|
|
s7_pointer s7_gc_on(s7_scheme *sc, bool on);
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>If you create an s7 object in C, that object
|
||
|
|
needs to be
|
||
|
|
GC protected if there is any chance the GC might run without
|
||
|
|
an existing Scheme-level reference to it. s7_gc_protect places the
|
||
|
|
object in a vector that the GC always checks, returning the object's location
|
||
|
|
in that table. s7_gc_unprotect_at unprotects the object (removes it from the
|
||
|
|
vector) using the location passed to it. s7_gc_protected_at returns the object
|
||
|
|
at the given location.
|
||
|
|
There is a built-in lag between the creation of a new object and its first possible GC
|
||
|
|
(the lag time is set indirectly by GC_TEMPS_SIZE in s7.c), so you don't need to worry about
|
||
|
|
very short term temps such as the arguments to s7_cons in:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_cons(s7, s7_make_real(s7, 3.14),
|
||
|
|
s7_cons(s7, s7_make_integer(s7, 123), s7_nil(s7)));
|
||
|
|
</pre>
|
||
|
|
<p>The protect_via_stack functions place the object on the s7 stack where it is
|
||
|
|
protected until the stack unwinds past that point. Besides speed, this provides
|
||
|
|
a way to be sure an object is unprotected even in some complicated situation where
|
||
|
|
error handling may bypass an explicit s7_gc_unprotect_at call.
|
||
|
|
The protect_via_location are intended for cases where you have a location already
|
||
|
|
(from s7_gc_protect), and want to reuse it for a different object.
|
||
|
|
s7_gc_on turns the GC on or off. Objects can be created at a blistering pace,
|
||
|
|
so don't leave the GC off for a long time!
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="shortheader" id="ccload">Load</div>
|
||
|
|
|
||
|
|
<pre class="indented">s7_pointer s7_load(s7_scheme *sc, const char *file);
|
||
|
|
s7_pointer s7_load_with_environment(s7_scheme *sc, const char *filename, s7_pointer e);
|
||
|
|
s7_pointer s7_load_c_string(s7_scheme *sc, const char *content, s7_int bytes);
|
||
|
|
s7_pointer s7_load_c_string_with_environment(s7_scheme *sc, const char *content, s7_int bytes, s7_pointer e);
|
||
|
|
s7_pointer s7_load_path(s7_scheme *sc);
|
||
|
|
s7_pointer s7_add_to_load_path(s7_scheme *sc, const char *dir);
|
||
|
|
s7_pointer s7_autoload(s7_scheme *sc, s7_pointer symbol, s7_pointer file_or_function);
|
||
|
|
void s7_autoload_set_names(s7_scheme *sc, const char **names, s7_int size); snd-xref.c
|
||
|
|
</pre>
|
||
|
|
<p>s7_load is similar to the scheme-side load function. Its argument is
|
||
|
|
a file name, and optionally (via s7_load_with_environment) an
|
||
|
|
environment
|
||
|
|
in which to place top-level objects. Normally the file contains scheme
|
||
|
|
code, but if WITH_C_LOADER is set when s7 is built, you can
|
||
|
|
also load shared-object files. If you load a shared-object file (a
|
||
|
|
dynamically loadable library), the environment argument
|
||
|
|
provides a way to pass in the initialization function (named
|
||
|
|
'init_func). For example, the repl in s7.c needs access to
|
||
|
|
libc's tcsetattr, so it looks for libc_s7.so (created by libc.scm). If
|
||
|
|
found,
|
||
|
|
</p>
|
||
|
|
<pre class="indented"> s7_load_with_environment(sc, "libc_s7.so",
|
||
|
|
s7_inlet(sc, s7_list(sc, 2, s7_make_symbol(sc, "init_func"),
|
||
|
|
s7_make_symbol(sc, "libc_s7_init")));
|
||
|
|
</pre>
|
||
|
|
<p>You can also include an 'init_args field to pass arguments to init_func. Here's an example that
|
||
|
|
includes init_args:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">/* tlib.c */
|
||
|
|
#include <stdio.h>
|
||
|
|
#include <stdlib.h>
|
||
|
|
#include "s7.h"
|
||
|
|
|
||
|
|
static s7_pointer a_function(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
return(s7_car(args));
|
||
|
|
}
|
||
|
|
|
||
|
|
s7_pointer tlib_init(s7_scheme *sc, s7_pointer args); /* void tlib_init(s7_scheme *sc) if no init_args */
|
||
|
|
s7_pointer tlib_init(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
fprintf(stderr, "tlib_init: %s\n", s7_object_to_c_string(sc, args));
|
||
|
|
s7_define_function(sc, "a-function", a_function, 1, 0, true, "");
|
||
|
|
return(s7_car(args));
|
||
|
|
}
|
||
|
|
|
||
|
|
/* in Linux:
|
||
|
|
gcc -fPIC -c tlib.c
|
||
|
|
gcc tlib.o -shared -o tlib.so -ldl -lm -Wl,-export-dynamic
|
||
|
|
|
||
|
|
/home/bil/cl/ repl
|
||
|
|
<1> (load "tlib.so" (inlet 'init_func 'tlib_init 'init_args (list 1 2 3)))
|
||
|
|
tlib_init: (1 2 3)
|
||
|
|
1
|
||
|
|
<2> (a-function 1 2 3)
|
||
|
|
1
|
||
|
|
*/
|
||
|
|
</pre>
|
||
|
|
<p>
|
||
|
|
s7_load returns the last value produced during the load; so given "test.scm" with the contents:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">define (f x) (+ x 1))
|
||
|
|
32
|
||
|
|
</pre>
|
||
|
|
<p>when we call s7_load:</p>
|
||
|
|
<pre class="indented">s7_pointer val;
|
||
|
|
val = s7_load_with_environment(sc, "test.scm", s7_curlet(sc));
|
||
|
|
</pre>
|
||
|
|
<p>val is set to 32 (as a scheme object), and f is placed in the current environment.
|
||
|
|
If "test.scm" is not in the current directory, s7 looks at the entries in its <a href="#loadpath">*load-path*</a> variable,
|
||
|
|
trying each in turn until it finds the file. If it fails, it returns NULL.
|
||
|
|
s7_load_path returns this list, and s7_add_to_load_path adds a directory name to the list.
|
||
|
|
</p>
|
||
|
|
<p>
|
||
|
|
s7_load_c_string takes an array of bytes representing some scheme code (xxd -i file.scm can generate these arrays),
|
||
|
|
and treats it as if it were the contents of a file of scheme code. So, unlike s7_eval_c_string, it can handle
|
||
|
|
multiple statements, and things like double-quote don't need to be quoted. nrepl.c for example
|
||
|
|
embeds the contents of nrepl.scm at compile time, then calls s7_load_c_string at program startup. It also
|
||
|
|
includes notcurses_s7.c. The end result is a stand-alone program that doesn't need to load either nrepl.scm
|
||
|
|
or notcurses_s7.so. The "content" argument should be a null-terminated C string. The "bytes" argument
|
||
|
|
is the contents length, not including the trailing null, as in strlen. There are simple examples in ffitest.c.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<p>xxd is not ideal in this context because diffs become enormous. I use this code to turn nrepl.scm
|
||
|
|
into nrepl-bits.h, following the original code's layout to minimize diffs:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(call-with-output-file "nrepl-bits.h"
|
||
|
|
(lambda (op)
|
||
|
|
(call-with-input-file "nrepl.scm"
|
||
|
|
(lambda (ip)
|
||
|
|
(format op "unsigned char nrepl_scm[] = {~% ")
|
||
|
|
(do ((c (read-char ip) (read-char ip))
|
||
|
|
(i 0 (+ i 1)))
|
||
|
|
((eof-object? c)
|
||
|
|
(format op "0};~%unsigned int nrepl_scm_len = ~D;~%" (+ i 1)))
|
||
|
|
(format op "0x~X, " (char->integer c))
|
||
|
|
(if (char=? c #\newline)
|
||
|
|
(format op "~% ")))))))
|
||
|
|
</pre>
|
||
|
|
<p>Then in nrepl.c:
|
||
|
|
</p>
|
||
|
|
<pre class="indented"> #include "nrepl-bits.h"
|
||
|
|
s7_load_c_string(sc, (const char *)nrepl_scm, nrepl_scm_len);
|
||
|
|
</pre>
|
||
|
|
<p>which replaces <code>s7_load(sc, "nrepl.scm")</code>.
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
<p>
|
||
|
|
s7_autoload adds a symbol to the <a href="#autoload">autoload table</a>. As a convenience,
|
||
|
|
s7_autoload_set_names adds an array of names+files. The array should be sorted alphabetically
|
||
|
|
by string<? acting on the symbol names (not the file names), and the size argument is the number
|
||
|
|
of symbol names (half the actual array size).
|
||
|
|
snd-xref.c in Snd has more than 5000 such
|
||
|
|
names:
|
||
|
|
</p>
|
||
|
|
<pre>static const char *snd_names[11848] = {
|
||
|
|
"*clm-array-print-length*", "ws.scm", /* each pair of entries is entity name + file name */
|
||
|
|
"*clm-channels*", "ws.scm", /* so clm-channels is defined in ws.scm */
|
||
|
|
...
|
||
|
|
"zone-tailed-hawk", "animals.scm",
|
||
|
|
"zoom-spectrum", "examp.scm",
|
||
|
|
};
|
||
|
|
|
||
|
|
s7_autoload_set_names(sc, snd_names, 5924);
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<div class="shortheader" id="cevalapply">Eval and Apply</div>
|
||
|
|
|
||
|
|
<pre class="indented">s7_pointer s7_eval(s7_scheme *sc, s7_pointer code, s7_pointer e);
|
||
|
|
s7_pointer s7_eval_c_string(s7_scheme *sc, const char *str);
|
||
|
|
s7_pointer s7_eval_c_string_with_environment(s7_scheme *sc, const char *str, s7_pointer e);
|
||
|
|
|
||
|
|
s7_pointer s7_apply_function(s7_scheme *sc, s7_pointer fnc, s7_pointer args);
|
||
|
|
s7_pointer s7_apply_function_star(s7_scheme *sc, s7_pointer fnc, s7_pointer args);
|
||
|
|
|
||
|
|
s7_pointer s7_call(s7_scheme *sc, s7_pointer func, s7_pointer args);
|
||
|
|
s7_pointer s7_call_with_location(s7_scheme *sc, s7_pointer func, s7_pointer args, const char *caller, const char *file, s7_int line);
|
||
|
|
s7_pointer s7_call_with_catch(s7_scheme *sc, s7_pointer tag, s7_pointer body, s7_pointer error_handler);
|
||
|
|
|
||
|
|
s7_pointer s7_apply_1(s7_scheme *sc, s7_pointer args, s7_pointer (*f1)(s7_pointer a1));
|
||
|
|
s7_pointer s7_apply_n_1(s7_scheme *sc, s7_pointer args, s7_pointer (*f1)(s7_pointer a1));
|
||
|
|
/* and many more passing 2 to 9 arguments */
|
||
|
|
</pre>
|
||
|
|
<p>These functions evaluate Scheme expressions, and call Scheme functions (which might be defined in C originally).
|
||
|
|
s7_eval evaluates a list that represents Scheme code. That is,
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_eval(sc, s7_cons(sc, s7_make_symbol(sc, "+"),
|
||
|
|
s7_cons(sc, s7_make_integer(sc, 1),
|
||
|
|
s7_cons(sc, s7_make_integer(sc, 2), s7_nil(sc)))),
|
||
|
|
s7_rootlet(sc)); /* s7_nil here is the same as s7_rootlet */
|
||
|
|
</pre>
|
||
|
|
<p>returns 3 (as a Scheme integer). This may look ridiculous, but see snd-sig.c for an actual use.
|
||
|
|
s7_eval_c_string evaluates a Scheme expression presented to it as a C string; it combines read and
|
||
|
|
eval, whereas s7_eval is just the eval portion.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_eval_c_string(sc, "(+ 1 2)");
|
||
|
|
</pre>
|
||
|
|
<p>also returns 3. The expression is evaluated in rootlet (the global environment). To specify the
|
||
|
|
environment, use s7_eval_c_string_with_environment.
|
||
|
|
</p>
|
||
|
|
<p>s7_apply_function and s7_apply_function_star take an s7_function and apply it to a list of arguments.
|
||
|
|
These two functions are the low-level versions of the s7_call functions. The latter set up various
|
||
|
|
catches so that error handling is safe, whereas s7_apply_function assumes you have a catch already somewhere.
|
||
|
|
</p>
|
||
|
|
<p>
|
||
|
|
s7_call_with_location passes some information to the error handler, and
|
||
|
|
s7_call_with_catch wraps an explicit catch around a function call:
|
||
|
|
s7_call_with_catch(sc, tag, body, err) is equivalent to (catch tag body err).
|
||
|
|
There are many examples of these functions in clm2xen.c, ffitest.c, etc.
|
||
|
|
</p>
|
||
|
|
<p>The s7_apply_1 functions and its many friends are left over from long ago. I hope to
|
||
|
|
deprecate them someday, but currently Snd uses them to excess. Each applies its function
|
||
|
|
to the arguments.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="shortheader" id="cdefine">Define</div>
|
||
|
|
|
||
|
|
<pre class="indented">void s7_define(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value);
|
||
|
|
bool s7_is_defined(s7_scheme *sc, const char *name);
|
||
|
|
|
||
|
|
s7_pointer s7_define_variable(s7_scheme *sc, const char *name, s7_pointer value);
|
||
|
|
s7_pointer s7_define_variable_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help);
|
||
|
|
|
||
|
|
s7_pointer s7_define_constant(s7_scheme *sc, const char *name, s7_pointer value);
|
||
|
|
s7_pointer s7_define_constant_with_documentation(s7_scheme *sc, const char *name, s7_pointer value, const char *help);
|
||
|
|
s7_pointer s7_define_constant_with_environment(s7_scheme *sc, s7_pointer envir, const char *name, s7_pointer value);
|
||
|
|
|
||
|
|
s7_pointer s7_define_function(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc);
|
||
|
|
s7_pointer s7_define_safe_function(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc);
|
||
|
|
s7_pointer s7_define_typed_function(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
s7_int required_args, s7_int optional_args, bool rest_arg,
|
||
|
|
const char *doc, s7_pointer signature);
|
||
|
|
s7_pointer s7_define_unsafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
s7_int required_args, s7_int optional_args, bool rest_arg,
|
||
|
|
const char *doc, s7_pointer signature);
|
||
|
|
s7_pointer s7_define_semisafe_typed_function(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
s7_int required_args, s7_int optional_args, bool rest_arg,
|
||
|
|
const char *doc, s7_pointer signature);
|
||
|
|
|
||
|
|
void s7_define_function_star(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
const char *arglist, const char *doc);
|
||
|
|
void s7_define_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
const char *arglist, const char *doc);
|
||
|
|
void s7_define_typed_function_star(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
const char *arglist, const char *doc, s7_pointer signature);
|
||
|
|
|
||
|
|
s7_pointer s7_define_macro(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc);
|
||
|
|
|
||
|
|
s7_pointer s7_make_function(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc);
|
||
|
|
s7_pointer s7_make_safe_function(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
s7_int required_args, s7_int optional_args, bool rest_arg, const char *doc);
|
||
|
|
s7_pointer s7_make_typed_function(s7_scheme *sc, const char *name, s7_function f,
|
||
|
|
s7_int required_args, s7_int optional_args, bool rest_arg,
|
||
|
|
const char *doc, s7_pointer signature);
|
||
|
|
|
||
|
|
s7_pointer s7_make_function_star(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
const char *arglist, const char *doc);
|
||
|
|
s7_pointer s7_make_safe_function_star(s7_scheme *sc, const char *name, s7_function fnc,
|
||
|
|
const char *arglist, const char *doc);
|
||
|
|
|
||
|
|
bool s7_is_dilambda(s7_pointer obj);
|
||
|
|
s7_pointer s7_dilambda(s7_scheme *sc,
|
||
|
|
const char *name,
|
||
|
|
s7_pointer (*getter)(s7_scheme *sc, s7_pointer args),
|
||
|
|
s7_int get_req_args, s7_int get_opt_args,
|
||
|
|
s7_pointer (*setter)(s7_scheme *sc, s7_pointer args),
|
||
|
|
s7_int set_req_args, s7_int set_opt_args,
|
||
|
|
const char *documentation);
|
||
|
|
s7_pointer s7_typed_dilambda(s7_scheme *sc,
|
||
|
|
const char *name,
|
||
|
|
s7_pointer (*getter)(s7_scheme *sc, s7_pointer args),
|
||
|
|
s7_int get_req_args, s7_int get_opt_args,
|
||
|
|
s7_pointer (*setter)(s7_scheme *sc, s7_pointer args),
|
||
|
|
s7_int set_req_args, s7_int set_opt_args,
|
||
|
|
const char *documentation,
|
||
|
|
s7_pointer get_sig, s7_pointer set_sig);
|
||
|
|
s7_pointer s7_dilambda_with_environment(s7_scheme *sc, s7_pointer envir,
|
||
|
|
const char *name,
|
||
|
|
s7_pointer (*getter)(s7_scheme *sc, s7_pointer args),
|
||
|
|
s7_int get_req_args, s7_int get_opt_args,
|
||
|
|
s7_pointer (*setter)(s7_scheme *sc, s7_pointer args),
|
||
|
|
s7_int set_req_args, s7_int set_opt_args,
|
||
|
|
const char *documentation);
|
||
|
|
</pre>
|
||
|
|
<p>The s7_define* functions add a symbol and its binding to either the top-level (global) environment
|
||
|
|
or, in s7_define, the 'env' passed as the second argument. Use s7_set_shadow_rootlet to
|
||
|
|
import the current let into rootlet.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_define(s7, s7_curlet(s7), s7_make_symbol(s7, "var"), s7_make_integer(s7, 123));
|
||
|
|
</pre>
|
||
|
|
<p>adds the variable named var to the current environment with the value 123.
|
||
|
|
Scheme code can then refer to var just as if we had said <code>(define var 123)</code>
|
||
|
|
in Scheme.
|
||
|
|
</p>
|
||
|
|
<p>s7_define_variable is a wrapper for s7_define; the code above could be:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_define_variable(s7, "var", s7_make_integer(s7, 123)); /* (define var 123) */
|
||
|
|
</pre>
|
||
|
|
<p>except that s7_define_variable assumes you want var in rootlet.
|
||
|
|
</p>
|
||
|
|
<p>s7_define_constant is another wrapper for s7_define; it makes the variable immutable:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_define_constant(sc, "var", s7_f(sc)); /* (define-constant var 123) */
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The rest of the functions in this section deal with tieing C functions into Scheme.
|
||
|
|
s7_make_function creates a Scheme function object from the s7_function 'fnc'.
|
||
|
|
An s7_function is a C function of the form <code>s7_pointer func(s7_scheme *sc, s7_pointer args)</code>.
|
||
|
|
The new function's name is 'name', it requires 'required_args' arguments,
|
||
|
|
it can accept 'optional_args' other arguments, and if 'rest_arg' is true, it accepts
|
||
|
|
a "rest" argument (a list of all the trailing arguments).
|
||
|
|
The function's documentation is 'doc'.
|
||
|
|
</p>
|
||
|
|
<p>s7_define_function is the same as s7_make_function, but it also adds 'name' (as a symbol) to the
|
||
|
|
global environment, with the function as its value. For example, the Scheme
|
||
|
|
function 'car' is essentially:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_pointer g_car(s7_scheme *sc, s7_pointer args) {return(s7_car(s7_car(args)));} /* args is a list of args */
|
||
|
|
</pre>
|
||
|
|
<p>It is bound to the name "car":
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_define_function(sc, "car", g_car, 1, 0, false, "(car obj)");
|
||
|
|
</pre>
|
||
|
|
<p>which says that car has one required argument, no optional arguments, and no "rest" argument.
|
||
|
|
</p>
|
||
|
|
<p>s7_define_macro defines a Scheme macro; its arguments are not evaluated (unlike a function),
|
||
|
|
but its returned value (assumed to be some sort of Scheme expression) is evaluated.
|
||
|
|
</p>
|
||
|
|
<p>The "safe" and "unsafe" versions of these functions refer to the s7 optimizer.
|
||
|
|
If it knows a function is safe, it can more thoroughly optimize the expression it is in.
|
||
|
|
"Safe" here means the function does not call the evaluator itself (via s7_apply_function for example)
|
||
|
|
and does not mess with s7's stack.
|
||
|
|
</p>
|
||
|
|
<p>The "typed" versions refer to the function's signature. Since "car" is safe, and has a signature,
|
||
|
|
it is defined in s7.c:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_define_typed_function(sc, "car", g_car, 1, 0, false, H_car, Q_car);
|
||
|
|
</pre>
|
||
|
|
<p>Here unless you use s7_define_unsafe_typed_function, the function is assumed to be safe.
|
||
|
|
We've given it the Scheme name "car", which invokes the C function g_car. It takes one
|
||
|
|
required argument, and no optional or rest arguments. Its documentation is H_car, and
|
||
|
|
its signature is Q_car. The latter is <code>s7_make_signature(sc, 2, sc->T, sc->is_pair_symbol)</code>
|
||
|
|
which says that car takes a pair argument, and returns any type object.
|
||
|
|
</p>
|
||
|
|
<p>The function_star functions are similar, but in this case we pass the argument list
|
||
|
|
as a string, as it would appear in Scheme.
|
||
|
|
s7 makes sure the arguments are ordered correctly and have the specified defaults before calling the C function.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_define_function_star(sc, "a-func", a_func, "arg1 (arg2 32)", "an example of C define*");
|
||
|
|
</pre>
|
||
|
|
<p>Now in Scheme, (a-func :arg1 2) calls the C function a_func with the arguments 2 and 32.
|
||
|
|
</p>
|
||
|
|
<p>Finally, the dilambda function define Scheme dilambda, just as the Scheme dilambda function does.
|
||
|
|
The dax example above gives read/write access to its x field via:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_define_variable(s7, "dax-x", s7_dilambda(s7, "dax-x", dax_x, 1, 0, set_dax_x, 2, 0, "dax x field"));
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="cfunctioninfo">Function info</div>
|
||
|
|
|
||
|
|
<pre class="indented">const char *s7_documentation(s7_scheme *sc, s7_pointer p);
|
||
|
|
const char *s7_set_documentation(s7_scheme *sc, s7_pointer symbol, const char *new_doc);
|
||
|
|
const char *s7_help(s7_scheme *sc, s7_pointer obj);
|
||
|
|
|
||
|
|
s7_pointer s7_arity(s7_scheme *sc, s7_pointer obj);
|
||
|
|
bool s7_is_aritable(s7_scheme *sc, s7_pointer obj, s7_int args);
|
||
|
|
|
||
|
|
s7_pointer s7_setter(s7_scheme *sc, s7_pointer obj);
|
||
|
|
s7_pointer s7_set_setter(s7_scheme *sc, s7_pointer obj, s7_pointer setter);
|
||
|
|
|
||
|
|
s7_pointer s7_signature(s7_scheme *sc, s7_pointer func);
|
||
|
|
s7_pointer s7_make_signature(s7_scheme *sc, s7_int len, ...);
|
||
|
|
s7_pointer s7_make_circular_signature(s7_scheme *sc, s7_int cycle_point, s7_int len, ...);
|
||
|
|
|
||
|
|
s7_pointer s7_closure_body(s7_scheme *sc, s7_pointer p);
|
||
|
|
s7_pointer s7_closure_let(s7_scheme *sc, s7_pointer p);
|
||
|
|
s7_pointer s7_closure_args(s7_scheme *sc, s7_pointer p);
|
||
|
|
s7_pointer s7_funclet(s7_scheme *sc, s7_pointer p);
|
||
|
|
</pre>
|
||
|
|
<p>These functions pertain mostly to functions, both those defined in Scheme and those in C.
|
||
|
|
s7_help and s7_documentation return the documentation string associated with their argument.
|
||
|
|
I find "documentation" tedious to type, and Snd uses "help", but other than the name,
|
||
|
|
there isn't much difference between them. s7_set_documentation sets the documentation string, if it can.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>s7_arity returns an object's arity, a cons of the number of required arguments, and the total acceptable arguments.
|
||
|
|
s7_is_aritable returns true if the object can accept that number of args.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>s7_setter is the object's <a href="#pws">setter</a>, and s7_set_setter sets it, if possible.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>s7_signature is the object's <a href="#signature">signature</a>, a list of types (symbols like 'integer?) giving return and argument types.
|
||
|
|
For a function defined in C, s7_make_signature and s7_make_circular_signature create the signature that is then
|
||
|
|
associated with the function via s7_define_typed_function and its friends.
|
||
|
|
In s7.c g_is_zero (the function that implements zero?) uses:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_make_signature(sc, 2, sc->is_boolean_symbol, sc->is_number_symbol); /* return a boolean, argument is a number */
|
||
|
|
</pre>
|
||
|
|
<p>Similarly, g_add is:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_make_circular_signature(sc, 0, 1, sc->is_number_symbol); /* returns a number, takes any number of numbers */
|
||
|
|
</pre>
|
||
|
|
<p>The two numeric arguments set the cycle start point (0-based) and the number of type symbols passed as arguments to it.
|
||
|
|
So, char=? is:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_make_circular_signature(sc, 1, 2, sc->is_boolean_symbol, sc->is_char_symbol);
|
||
|
|
</pre>
|
||
|
|
<p>which says there are two type entries (the "2"), and the cycle starts at the second (the "1" -- it's 0-based).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>The s7_closure functions only apply to functions defined in Scheme. They return the closure body (s7_closure_body, a list),
|
||
|
|
its definition environment (s7_closure_let), and its argument list (s7_closure_args). If the function is of the form
|
||
|
|
<code>(define (f . args) ...)</code>, s7_closure_args returns the symbol ('args in this case).
|
||
|
|
s7_funclet returns the top let within the function (the let containing the argument names).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="ccobjects">C-objects</div>
|
||
|
|
|
||
|
|
<pre class="indented">bool s7_is_c_object(s7_pointer p);
|
||
|
|
s7_pointer s7_make_c_object(s7_scheme *sc, s7_int type, void *value);
|
||
|
|
s7_pointer s7_make_c_object_without_gc(s7_scheme *sc, s7_int type, void *value);
|
||
|
|
s7_pointer s7_make_c_object_with_let(s7_scheme *sc, s7_int type, void *value, s7_pointer let);
|
||
|
|
|
||
|
|
s7_int s7_c_object_type(s7_pointer obj);
|
||
|
|
void *s7_c_object_value(s7_pointer obj);
|
||
|
|
void *s7_c_object_value_checked(s7_pointer obj, s7_int type);
|
||
|
|
s7_pointer s7_c_object_let(s7_pointer obj);
|
||
|
|
s7_pointer s7_c_object_set_let(s7_scheme *sc, s7_pointer obj, s7_pointer e);
|
||
|
|
|
||
|
|
s7_int s7_make_c_type(s7_scheme *sc, const char *name);
|
||
|
|
void s7_c_type_set_gc_free (s7_scheme *sc, s7_int type, s7_pointer (*gc_free) (s7_scheme *sc, s7_pointer obj));
|
||
|
|
void s7_c_type_set_gc_mark (s7_scheme *sc, s7_int type, s7_pointer (*mark) (s7_scheme *sc, s7_pointer obj));
|
||
|
|
void s7_c_type_set_is_equal (s7_scheme *sc, s7_int type, s7_pointer (*is_equal) (s7_scheme *sc, s7_pointer args));
|
||
|
|
void s7_c_type_set_is_equivalent(s7_scheme *sc, s7_int type, s7_pointer (*is_equivalent)(s7_scheme *sc, s7_pointer args));
|
||
|
|
void s7_c_type_set_ref (s7_scheme *sc, s7_int type, s7_pointer (*ref) (s7_scheme *sc, s7_pointer args));
|
||
|
|
void s7_c_type_set_set (s7_scheme *sc, s7_int type, s7_pointer (*set) (s7_scheme *sc, s7_pointer args));
|
||
|
|
void s7_c_type_set_length (s7_scheme *sc, s7_int type, s7_pointer (*length) (s7_scheme *sc, s7_pointer args));
|
||
|
|
void s7_c_type_set_copy (s7_scheme *sc, s7_int type, s7_pointer (*copy) (s7_scheme *sc, s7_pointer args));
|
||
|
|
void s7_c_type_set_fill (s7_scheme *sc, s7_int type, s7_pointer (*fill) (s7_scheme *sc, s7_pointer args));
|
||
|
|
void s7_c_type_set_reverse (s7_scheme *sc, s7_int type, s7_pointer (*reverse) (s7_scheme *sc, s7_pointer args));
|
||
|
|
void s7_c_type_set_to_list (s7_scheme *sc, s7_int type, s7_pointer (*to_list) (s7_scheme *sc, s7_pointer args));
|
||
|
|
void s7_c_type_set_to_string (s7_scheme *sc, s7_int type, s7_pointer (*to_string) (s7_scheme *sc, s7_pointer args));
|
||
|
|
void s7_c_type_set_getter (s7_scheme *sc, s7_int type, s7_pointer getter);
|
||
|
|
void s7_c_type_set_setter (s7_scheme *sc, s7_int type, s7_pointer setter);
|
||
|
|
|
||
|
|
void s7_mark(s7_pointer p);
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>These functions create a new Scheme object type. See <a href="#pwstype">dax</a> above for a simple example,
|
||
|
|
and s7test.scm for several progressively more complicated examples.
|
||
|
|
C-objects in Scheme usually correspond to an instance of a struct in C which you want to access from Scheme.
|
||
|
|
The normal sequence is: define a new c-type via s7_make_c_type, call s7_c_type_set* to specialize its behavior,
|
||
|
|
then to wrap a C object, call s7_make_c_object.
|
||
|
|
s7_make_c_type takes an arbitrary name, used in object->string to identify the object, and returns an s7_int, the "type"
|
||
|
|
mentioned in many of the other functions.
|
||
|
|
</p>
|
||
|
|
<p>s7_c_type_set_free sets the function that is called by the GC when a Scheme c-object is garbage-collected.
|
||
|
|
You normally use this to free the associated C value (the instance of the struct). To get that value,
|
||
|
|
call s7_c_object_value. It returns the void* pointer that you originally passed to s7_make_c_object.
|
||
|
|
See free_dax in the <a href="#pwstype">dax</a> example.
|
||
|
|
</p>
|
||
|
|
<p>s7_c_type_set_mark sets the function that is called by the GC during its marking phase. Any s7_pointer
|
||
|
|
value local to your C struct should be marked explicitly at this time, or the GC will free it. Use s7_mark
|
||
|
|
for this (see mark_dax).
|
||
|
|
</p>
|
||
|
|
<p>s7_c_type_set_equal and s7_c_type_set_equivalent set the function called when s7 sees a c-object of the
|
||
|
|
current type as an argument to equal? or equivalent?. When called, these functions can assume that the
|
||
|
|
first argument is a c-object of the current type, but the second argument can be anything (see dax_is_equal).
|
||
|
|
</p>
|
||
|
|
<p>s7_c_type_set_ref and s7_c_type_set_set are called when the c-object is treated as an applicable object
|
||
|
|
in Scheme. That is, <code>(object ...)</code> in Scheme calls the function set as the "ref" function, and
|
||
|
|
<code>(set! (object ...) new-value)</code> calls the "set" function. The arguments in the set! form are
|
||
|
|
passed as a flattened list.
|
||
|
|
</p>
|
||
|
|
<p>The rest of the s7_c_type_set* functions set the functions called when the c-object is an argument to
|
||
|
|
length (s7_c_type_set_length), copy (s7_c_type_set_copy), fill! (s7_c_type_set_fill), reverse (s7_c_type_set_reverse),
|
||
|
|
object->string (s7_c_type_set_to_string), and internally by map and a few other cases, s7_c_type_set_to_list.
|
||
|
|
For the copy function, either the first or second argument can be a c-object of the given type.
|
||
|
|
The getter and setter functions are optimizer helpers.
|
||
|
|
</p>
|
||
|
|
<p>s7_c_object_value_checked is like s7_c_object, but it first checks that the object type matches the given type.
|
||
|
|
</p>
|
||
|
|
<p>s7_c_object_let and s7_c_object_set_let manage the c-object's local environment.
|
||
|
|
These two functions need to check that they are passed the correct number of arguments.
|
||
|
|
See the block object in s7test.scm. The c_object_let provides methods normally.
|
||
|
|
In Snd, marks can be passed into Scheme; the setup code is:
|
||
|
|
</p>
|
||
|
|
<pre class="indented"> static s7_pointer g_mark_methods;
|
||
|
|
...
|
||
|
|
g_mark_methods = s7_openlet(s7,
|
||
|
|
s7_inlet(s7, s7_list(s7, 2, s7_make_symbol(s7, "object->let"),
|
||
|
|
mark_to_let_func)));
|
||
|
|
s7_gc_protect(s7, g_mark_methods);
|
||
|
|
xen_mark_tag = s7_make_c_type(s7, "<mark>");
|
||
|
|
s7_c_type_set_gc_free(s7, xen_mark_tag, s7_xen_mark_free);
|
||
|
|
s7_c_type_set_is_equal(s7, xen_mark_tag, s7_xen_mark_is_equal);
|
||
|
|
s7_c_type_set_copy(s7, xen_mark_tag, s7_xen_mark_copy);
|
||
|
|
s7_c_type_set_to_string(s7, xen_mark_tag, g_xen_mark_to_string);
|
||
|
|
</pre>
|
||
|
|
<p>The mark object's let (g_mark_methods) has a method for object->let.
|
||
|
|
It is tied into each mark object:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_pointer m;
|
||
|
|
m = s7_make_c_object(s7, xen_mark_tag, mx); /* mx is the C-side value */
|
||
|
|
s7_c_object_set_let(s7, m, g_mark_methods);
|
||
|
|
</pre>
|
||
|
|
<p>and now if you type (object->let mark) in Snd's listener (where "mark" is
|
||
|
|
an appropriate mark of course), object->let calls the object's object->let method.
|
||
|
|
Don't forget to GC-protect the let!
|
||
|
|
</p>
|
||
|
|
<p>s7_make_c_object_without_gc makes a c-object of the given type, but the gc_free function
|
||
|
|
won't be called when the s7_cell that holds the C data is freed for reuse.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="shortheader" id="cio">IO</div>
|
||
|
|
<pre class="indented">bool s7_is_input_port(s7_scheme *sc, s7_pointer p);
|
||
|
|
bool s7_is_output_port(s7_scheme *sc, s7_pointer p);
|
||
|
|
void s7_close_input_port(s7_scheme *sc, s7_pointer p);
|
||
|
|
void s7_close_output_port(s7_scheme *sc, s7_pointer p);
|
||
|
|
bool s7_flush_output_port(s7_scheme *sc, s7_pointer p); /* false=flush lost data */
|
||
|
|
const char *s7_port_filename(s7_scheme *sc, s7_pointer x);
|
||
|
|
s7_int s7_port_line_number(s7_scheme *sc, s7_pointer p);
|
||
|
|
|
||
|
|
s7_pointer s7_open_input_file(s7_scheme *sc, const char *name, const char *mode);
|
||
|
|
s7_pointer s7_open_output_file(s7_scheme *sc, const char *name, const char *mode);
|
||
|
|
|
||
|
|
s7_pointer s7_open_input_string(s7_scheme *sc, const char *input_string);
|
||
|
|
s7_pointer s7_open_output_string(s7_scheme *sc);
|
||
|
|
const char *s7_get_output_string(s7_scheme *sc, s7_pointer out_port);
|
||
|
|
s7_pointer s7_output_string(s7_scheme *sc, s7_pointer out_port);
|
||
|
|
|
||
|
|
typedef enum {S7_READ, S7_READ_CHAR, S7_READ_LINE, S7_PEEK_CHAR, S7_IS_CHAR_READY, S7_NUM_READ_CHOICES} s7_read_t;
|
||
|
|
s7_pointer s7_open_output_function(s7_scheme *sc, void (*function)(s7_scheme *sc, uint8_t c, s7_pointer port));
|
||
|
|
s7_pointer s7_open_input_function(s7_scheme *sc, s7_pointer (*function)(s7_scheme *sc, s7_read_t read_choice, s7_pointer port));
|
||
|
|
|
||
|
|
s7_pointer s7_read_char(s7_scheme *sc, s7_pointer port);
|
||
|
|
s7_pointer s7_peek_char(s7_scheme *sc, s7_pointer port);
|
||
|
|
s7_pointer s7_write_char(s7_scheme *sc, s7_pointer c, s7_pointer port);
|
||
|
|
s7_pointer s7_write(s7_scheme *sc, s7_pointer obj, s7_pointer port);
|
||
|
|
s7_pointer s7_display(s7_scheme *sc, s7_pointer obj, s7_pointer port);
|
||
|
|
void s7_newline(s7_scheme *sc, s7_pointer port);
|
||
|
|
const char *s7_format(s7_scheme *sc, s7_pointer args);
|
||
|
|
s7_pointer s7_object_to_string(s7_scheme *sc, s7_pointer arg, bool use_write);
|
||
|
|
char *s7_object_to_c_string(s7_scheme *sc, s7_pointer obj);
|
||
|
|
|
||
|
|
s7_pointer s7_current_input_port(s7_scheme *sc);
|
||
|
|
s7_pointer s7_set_current_input_port(s7_scheme *sc, s7_pointer p);
|
||
|
|
s7_pointer s7_current_output_port(s7_scheme *sc);
|
||
|
|
s7_pointer s7_set_current_output_port(s7_scheme *sc, s7_pointer p);
|
||
|
|
s7_pointer s7_current_error_port(s7_scheme *sc);
|
||
|
|
s7_pointer s7_set_current_error_port(s7_scheme *sc, s7_pointer port);
|
||
|
|
|
||
|
|
s7_pointer s7_read(s7_scheme *sc, s7_pointer port);
|
||
|
|
</pre>
|
||
|
|
<p>Most of these correspond closely to the similarly named scheme function. s7_port_filename
|
||
|
|
returns the file associated with a file port. s7_port_line_number returns position of the
|
||
|
|
reader in an input file port. The "use_write" parameter to s7_object_to_string refers
|
||
|
|
to the write/display choice in scheme. The string returned by s7_object_to_c_string
|
||
|
|
should be freed by the caller.
|
||
|
|
s7_output_string is the same as s7_get_output_string except that it returns an s7 string,
|
||
|
|
not a C string.
|
||
|
|
</p>
|
||
|
|
<p>s7_open_input_function and s7_open_output_function
|
||
|
|
call their "function" argument when input or output is requested. The "read_choice"
|
||
|
|
argument specifies to that function which of the input scheme functions called it.
|
||
|
|
The intent of these two input functions is to give you complete control over IO.
|
||
|
|
In the case of an input_function:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">static s7_pointer my_read(s7_scheme *sc, s7_read_t peek, s7_pointer port)
|
||
|
|
{
|
||
|
|
/* this function should handle input according to the peek choice */
|
||
|
|
return(s7_make_character(sc, '0'));
|
||
|
|
}
|
||
|
|
|
||
|
|
s7_pointer port;
|
||
|
|
s7_int gc_loc;
|
||
|
|
uint8_t c;
|
||
|
|
port = s7_open_input_function(sc, my_read);
|
||
|
|
gc_loc = s7_gc_protect(sc, port);
|
||
|
|
c = s7_character(s7_read_char(sc, p1)); /* my_read "peek" == S7_READ_CHAR */
|
||
|
|
if (last_c != '0')
|
||
|
|
fprintf(stderr, "c: %c\n", c);
|
||
|
|
s7_gc_unprotect_at(sc, gc_loc);
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="clets">Lets</div>
|
||
|
|
<pre class="indented">s7_pointer s7_rootlet(s7_scheme *sc);
|
||
|
|
s7_pointer s7_shadow_rootlet(s7_scheme *sc);
|
||
|
|
s7_pointer s7_set_shadow_rootlet(s7_scheme *sc, s7_pointer let);
|
||
|
|
|
||
|
|
s7_pointer s7_curlet(s7_scheme *sc);
|
||
|
|
s7_pointer s7_set_curlet(s7_scheme *sc, s7_pointer e);
|
||
|
|
|
||
|
|
s7_pointer s7_outlet(s7_scheme *sc, s7_pointer e);
|
||
|
|
s7_pointer s7_sublet(s7_scheme *sc, s7_pointer let, s7_pointer bindings);
|
||
|
|
s7_pointer s7_inlet(s7_scheme *sc, s7_pointer bindings);
|
||
|
|
s7_pointer s7_varlet(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer value);
|
||
|
|
|
||
|
|
s7_pointer s7_let_to_list(s7_scheme *sc, s7_pointer let);
|
||
|
|
bool s7_is_let(s7_pointer e);
|
||
|
|
s7_pointer s7_let_ref(s7_scheme *sc, s7_pointer let, s7_pointer symbol);
|
||
|
|
s7_pointer s7_let_set(s7_scheme *sc, s7_pointer let, s7_pointer symbol, s7_pointer val);
|
||
|
|
s7_pointer s7_let_field_ref(s7_scheme *sc, s7_pointer symbol);
|
||
|
|
s7_pointer s7_let_field_set(s7_scheme *sc, s7_pointer symbol, s7_pointer new_value);
|
||
|
|
|
||
|
|
s7_pointer s7_openlet(s7_scheme *sc, s7_pointer e);
|
||
|
|
bool s7_is_openlet(s7_pointer e);
|
||
|
|
s7_pointer s7_method(s7_scheme *sc, s7_pointer object, s7_pointer method);
|
||
|
|
|
||
|
|
/* these might go away someday */
|
||
|
|
s7_pointer s7_slot(s7_scheme *sc, s7_pointer symbol);
|
||
|
|
s7_pointer s7_slot_value(s7_pointer slot);
|
||
|
|
s7_pointer s7_slot_set_value(s7_scheme *sc, s7_pointer slot, s7_pointer value);
|
||
|
|
s7_pointer s7_make_slot(s7_scheme *sc, s7_pointer env, s7_pointer symbol, s7_pointer value);
|
||
|
|
void s7_slot_set_real_value(s7_scheme *sc, s7_pointer slot, s7_double value);
|
||
|
|
</pre>
|
||
|
|
<p>Many of these are the same as the corresponding scheme function: s7_rootlet, s7_curlet, s7_outlet,
|
||
|
|
s7_sublet, s7_inlet, s7_varlet, s7_let_to_list, s7_is_let, s7_let_ref, s7_let_set, s7_openlet,
|
||
|
|
and s7_is_openlet.
|
||
|
|
</p>
|
||
|
|
<p>s7_let_field_ref and s7_let_field_set refer to *s7*, the let that holds various s7 settings.
|
||
|
|
To get the current default print-length,
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_integer(s7_let_field_ref(s7, s7_make_symbol(s7, "print-length")))
|
||
|
|
</pre>
|
||
|
|
<p>s7_method looks for a field in "object" with the name "method", a symbol.
|
||
|
|
For example, in clm2xen.c, if mus-copy is called on an object that Snd does not
|
||
|
|
immediately recognize (i.e. a generator), it looks for a mus-copy method, and
|
||
|
|
if found, Snd calls it:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_pointer func;
|
||
|
|
func = s7_method(s7, gen, s7_make_symbol(s7, "mus-copy"));
|
||
|
|
if (func != s7_undefined(s7))
|
||
|
|
return(s7_apply_function(s7, func, s7_list(s7, 1, gen)));
|
||
|
|
</pre>
|
||
|
|
<p>The object searched can be anything that has an associated let: a c-object,
|
||
|
|
a function or macro, a c-pointer, or of course a let.
|
||
|
|
</p>
|
||
|
|
<p>s7_set_curlet and the slot functions might go away someday. They are currently used
|
||
|
|
in Snd. For the adventurous however, here's a sketchy description.
|
||
|
|
A slot in s7 is a location in a let (a variable binding in an environment to use more standard terminology).
|
||
|
|
s7_make_slot creates a slot in "env" with the given symbol and value. s7_slot_value returns the value;
|
||
|
|
s7_slot_set_value sets the value; s7_slot_set_real_value sets the mutable real value's numerical value.
|
||
|
|
s7_slot takes a symbol and tries to find its currently active slot. s7_set_curlet sets curlet, returning
|
||
|
|
the previous curlet.
|
||
|
|
</p>
|
||
|
|
<p>s7_shadow_rootlet and s7_set_shadow_rootlet make it easier to import a let into rootlet. This is also aimed
|
||
|
|
at code that is defining lots of functions and variables, using the default functions like s7_define_variable
|
||
|
|
that place things in the rootlet, but the code actually wants all those objects stored
|
||
|
|
in a let other than rootlet.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_pointer cur_env, old_shadow;
|
||
|
|
cur_env = s7_curlet(sc);
|
||
|
|
old_shadow = s7_set_shadow_rootlet(sc, cur_env);
|
||
|
|
/* define everything here */
|
||
|
|
s7_set_shadow_rootlet(sc, old_shadow);
|
||
|
|
</pre>
|
||
|
|
<p>s7_set_shadow_rootlet returns the previous shadow rootlet,
|
||
|
|
so this turns the current environment into a shadow rootlet while defining functions, then restores
|
||
|
|
the old rootlet.
|
||
|
|
Similarly notcurses_s7.c places everything in the *notcurses* let,
|
||
|
|
but uses s7_set_shadow_rootlet to make these available in scheme as if they were in the rootlet:
|
||
|
|
</p>
|
||
|
|
<pre class="indented"> s7_pointer notcurses_let, old_shadow;
|
||
|
|
s7_define_constant(sc, "*notcurses*", notcurses_let = s7_inlet(sc, s7_nil(sc)));
|
||
|
|
old_shadow = s7_set_shadow_rootlet(sc, notcurses_let);
|
||
|
|
/* ... here we have all the s7_defines ... */
|
||
|
|
s7_set_shadow_rootlet(sc, old_shadow);
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<div class="shortheader" id="csymbols">Symbols</div>
|
||
|
|
<pre class="indented">bool s7_is_symbol(s7_pointer p);
|
||
|
|
const char *s7_symbol_name(s7_pointer p);
|
||
|
|
s7_pointer s7_make_symbol(s7_scheme *sc, const char *name);
|
||
|
|
s7_pointer s7_gensym(s7_scheme *sc, const char *prefix);
|
||
|
|
|
||
|
|
bool s7_is_keyword(s7_pointer obj);
|
||
|
|
s7_pointer s7_make_keyword(s7_scheme *sc, const char *key);
|
||
|
|
s7_pointer s7_keyword_to_symbol(s7_scheme *sc, s7_pointer key);
|
||
|
|
|
||
|
|
s7_pointer s7_name_to_value(s7_scheme *sc, const char *name);
|
||
|
|
s7_pointer s7_symbol_value(s7_scheme *sc, s7_pointer sym);
|
||
|
|
s7_pointer s7_symbol_set_value(s7_scheme *sc, s7_pointer sym, s7_pointer val);
|
||
|
|
s7_pointer s7_symbol_local_value(s7_scheme *sc, s7_pointer sym, s7_pointer local_env);
|
||
|
|
|
||
|
|
s7_pointer s7_symbol_table_find_name(s7_scheme *sc, const char *name);
|
||
|
|
bool s7_for_each_symbol_name(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data);
|
||
|
|
bool s7_for_each_symbol(s7_scheme *sc, bool (*symbol_func)(const char *symbol_name, void *data), void *data);
|
||
|
|
</pre>
|
||
|
|
<p>s7_is_symbol corresponds to scheme's symbol?, s7_symbol_name to symbol->string,
|
||
|
|
s7_make_symbol is string->symbol,
|
||
|
|
s7_gensym to gensym. The gensym prefix is the optional argument to gensym in scheme.
|
||
|
|
By default the prefix is "gensym", so the gensym-created symbols are of the form {gensym}-nnn
|
||
|
|
where nnn is some number. s7_is_keyword is keyword?, s7_make_keyword is string->keyword,
|
||
|
|
and s7_keyword_to_symbol is keyword->symbol.
|
||
|
|
</p>
|
||
|
|
<p>Normal symbols, and keywords do not need to be garbage-protected, but gensyms do.
|
||
|
|
</p>
|
||
|
|
<p>s7_symbol_to_value finds the current binding of the symbol (using its string name),
|
||
|
|
and returns its value, similar to symbol->value. To specify the environment in which to
|
||
|
|
lookup the symbol, use s7_symbol_local_value. s7_symbol_set_value sets the value of the
|
||
|
|
symbol in its current binding.
|
||
|
|
</p>
|
||
|
|
<p>s7_symbol_table_find_name finds the symbol given its name. s7_make_symbol is the same
|
||
|
|
if the symbol already exists, but s7_symbol_find_by_name returns NULL if there isn't any
|
||
|
|
symbol by that name.
|
||
|
|
s7_for_each_symbol_name and s7_for_each_symbol traverse the symbol
|
||
|
|
table, calling "symbol_func" on each symbol. symbol_func is a boolean function that
|
||
|
|
takes as arguments the symbol name and the void* data pointer. The latter can carry
|
||
|
|
along whatever state your function needs. s7_for_each_symbol_name also includes some
|
||
|
|
s7 constants like #f.
|
||
|
|
</p>
|
||
|
|
<p>The C declaration above says s7_for_each_symbol is a C function that returns a boolean,
|
||
|
|
and takes three arguments, an s7_scheme* pointer, a function (symbol_func), and a void* pointer
|
||
|
|
(data). The function passed (symbol_func) also returns a boolean, and takes two arguments, a char* (name),
|
||
|
|
and the same void* pointer that was passed to s7_symbol_for_each. If symbol_func returns true,
|
||
|
|
the outer function immediately returns true, ending the symbol table traversal.
|
||
|
|
Sketched in scheme, it might be:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(define (s7_for_each_symbol s7 symbol_func data)
|
||
|
|
(call-with-exit
|
||
|
|
(lambda (return)
|
||
|
|
(for-each
|
||
|
|
(lambda (symbol-name)
|
||
|
|
(if (symbol_func symbol-name data)
|
||
|
|
(return #t)))
|
||
|
|
(symbol-table))
|
||
|
|
#f)))
|
||
|
|
</pre>
|
||
|
|
<p>An example is snd-completion.c.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="cnumbers">Numbers</div>
|
||
|
|
<pre class="indented">bool s7_is_number(s7_pointer p);
|
||
|
|
char *s7_number_to_string(s7_scheme *sc, s7_pointer obj, s7_int radix);
|
||
|
|
|
||
|
|
bool s7_is_integer(s7_pointer p);
|
||
|
|
s7_int s7_integer(s7_pointer p);
|
||
|
|
s7_pointer s7_make_integer(s7_scheme *sc, s7_int num);
|
||
|
|
s7_int s7_number_to_integer(s7_scheme *sc, s7_pointer x);
|
||
|
|
s7_int s7_number_to_integer_with_caller(s7_scheme *sc, s7_pointer x, const char *caller);
|
||
|
|
|
||
|
|
bool s7_is_real(s7_pointer p);
|
||
|
|
s7_double s7_real(s7_pointer p);
|
||
|
|
s7_pointer s7_make_real(s7_scheme *sc, s7_double num);
|
||
|
|
s7_pointer s7_make_mutable_real(s7_scheme *sc, s7_double n);
|
||
|
|
s7_double s7_number_to_real(s7_scheme *sc, s7_pointer x);
|
||
|
|
s7_double s7_number_to_real_with_caller(s7_scheme *sc, s7_pointer x, const char *caller);
|
||
|
|
|
||
|
|
bool s7_is_rational(s7_pointer arg);
|
||
|
|
bool s7_is_ratio(s7_pointer arg);
|
||
|
|
s7_pointer s7_make_ratio(s7_scheme *sc, s7_int a, s7_int b);
|
||
|
|
s7_pointer s7_rationalize(s7_scheme *sc, s7_double x, s7_double error);
|
||
|
|
s7_int s7_numerator(s7_pointer x);
|
||
|
|
s7_int s7_denominator(s7_pointer x);
|
||
|
|
|
||
|
|
bool s7_is_complex(s7_pointer arg);
|
||
|
|
s7_pointer s7_make_complex(s7_scheme *sc, s7_double a, s7_double b);
|
||
|
|
s7_double s7_real_part(s7_pointer z);
|
||
|
|
s7_double s7_imag_part(s7_pointer z);
|
||
|
|
|
||
|
|
s7_double s7_random(s7_scheme *sc, s7_pointer state);
|
||
|
|
s7_pointer s7_random_state(s7_scheme *sc, s7_pointer seed);
|
||
|
|
bool s7_is_random_state(s7_pointer p);
|
||
|
|
s7_pointer s7_random_state_to_list(s7_scheme *sc, s7_pointer args);
|
||
|
|
void s7_set_default_random_state(s7_scheme *sc, s7_int seed, s7_int carry);
|
||
|
|
|
||
|
|
bool s7_is_bignum(s7_pointer obj);
|
||
|
|
mpfr_t *s7_big_real(s7_pointer x);
|
||
|
|
mpz_t *s7_big_integer(s7_pointer x);
|
||
|
|
mpq_t *s7_big_ratio(s7_pointer x);
|
||
|
|
mpc_t *s7_big_complex(s7_pointer x);
|
||
|
|
s7_pointer s7_make_big_integer(s7_scheme *sc, mpz_t *val);
|
||
|
|
s7_pointer s7_make_big_ratio(s7_scheme *sc, mpq_t *val);
|
||
|
|
s7_pointer s7_make_big_real(s7_scheme *sc, mpfr_t *val);
|
||
|
|
s7_pointer s7_make_big_complex(s7_scheme *sc, mpc_t *val);
|
||
|
|
</pre>
|
||
|
|
<p>Most of these correspond to the obvious scheme functions, so I'll
|
||
|
|
only touch on the less-obvious cases.
|
||
|
|
s7_make_mutable_real returns a real number object whose value can be changed directly.
|
||
|
|
In snd-sig.c, for example, we have a C procedure that applies a scheme function to
|
||
|
|
every sound sample in an audio file. We do not want to create a new object for the
|
||
|
|
scheme function's argument list on every call! So, we start by creating the mutable real:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">yp = s7_make_slot(s7, e, arg, s7_make_mutable_real(s7, 1.5));
|
||
|
|
</pre>
|
||
|
|
<p>"e" is the let for the evaluation, "arg" is the real's name as a symbol in that let,
|
||
|
|
and we make its initial value 1.5 (for no particular reason). Then on every sample, we
|
||
|
|
call the function:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">s7_slot_set_real_value(s7, yp, data[kp]); /* set yp's value to data[kp] */
|
||
|
|
data[kp] = opt_func(s7, res); /* call opt_func */
|
||
|
|
</pre>
|
||
|
|
<p>s7_number_to_real returns any real number as an s7_double. If it can't
|
||
|
|
convert its argument, it signals an error, which is annoying because it doesn't
|
||
|
|
know where that error occured in scheme. So s7_number_to_real_with_caller gives
|
||
|
|
you a way to tell it at lease the caller's name.
|
||
|
|
</p>
|
||
|
|
<p>For the bignum functions, see <a href="#gmpex">Bignums in C</a>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="clists">Lists</div>
|
||
|
|
<pre class="indented">bool s7_is_pair(s7_pointer p);
|
||
|
|
s7_pointer s7_cons(s7_scheme *sc, s7_pointer a, s7_pointer b);
|
||
|
|
|
||
|
|
s7_pointer s7_car(s7_pointer p);
|
||
|
|
s7_pointer s7_cdr(s7_pointer p);
|
||
|
|
s7_pointer s7_set_car(s7_pointer p, s7_pointer q);
|
||
|
|
s7_pointer s7_set_cdr(s7_pointer p, s7_pointer q);
|
||
|
|
s7_pointer s7_cadr(s7_pointer p);
|
||
|
|
etc...
|
||
|
|
|
||
|
|
bool s7_is_list(s7_scheme *sc, s7_pointer p);
|
||
|
|
bool s7_is_proper_list(s7_scheme *sc, s7_pointer p);
|
||
|
|
s7_pointer s7_make_list(s7_scheme *sc, s7_int length, s7_pointer initial_value);
|
||
|
|
s7_int s7_list_length(s7_scheme *sc, s7_pointer a);
|
||
|
|
s7_pointer s7_list(s7_scheme *sc, s7_int num_values, ...);
|
||
|
|
s7_pointer s7_list_nl(s7_scheme *sc, s7_int num_values, ...);
|
||
|
|
s7_pointer s7_array_to_list(s7_scheme *sc, s7_int num_values, s7_pointer *array);
|
||
|
|
s7_pointer s7_list_ref(s7_scheme *sc, s7_pointer lst, s7_int num);
|
||
|
|
s7_pointer s7_list_set(s7_scheme *sc, s7_pointer lst, s7_int num, s7_pointer val);
|
||
|
|
|
||
|
|
s7_pointer s7_reverse(s7_scheme *sc, s7_pointer a);
|
||
|
|
s7_pointer s7_append(s7_scheme *sc, s7_pointer a, s7_pointer b);
|
||
|
|
s7_pointer s7_assoc(s7_scheme *sc, s7_pointer obj, s7_pointer lst);
|
||
|
|
s7_pointer s7_assq(s7_scheme *sc, s7_pointer obj, s7_pointer x);
|
||
|
|
s7_pointer s7_member(s7_scheme *sc, s7_pointer obj, s7_pointer lst);
|
||
|
|
s7_pointer s7_memq(s7_scheme *sc, s7_pointer obj, s7_pointer x);
|
||
|
|
bool s7_tree_memq(s7_scheme *sc, s7_pointer sym, s7_pointer tree);
|
||
|
|
</pre>
|
||
|
|
<p>These functions are mostly obvious: s7_car corresponds to scheme car, etc.
|
||
|
|
s7_list_nl was added to catch a typo that affected s7_list: the latter would accept
|
||
|
|
trailing, but ignored list values. s7_tree_memq is like s7_memq, but searches
|
||
|
|
an entire tree structure. not just the top-level list. s7_array_to_list takes
|
||
|
|
an array of s7_pointers and returns a list of them (similar to s7_vector_to_list).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="cvectors">Vectors</div>
|
||
|
|
<pre class="indented">s7_pointer s7_make_vector(s7_scheme *sc, s7_int len);
|
||
|
|
s7_pointer s7_make_and_fill_vector(s7_scheme *sc, s7_int len, s7_pointer fill);
|
||
|
|
s7_pointer s7_make_normal_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info);
|
||
|
|
bool s7_is_vector(s7_pointer p);
|
||
|
|
|
||
|
|
s7_int s7_vector_length(s7_pointer vec);
|
||
|
|
s7_int s7_vector_rank(s7_pointer vect);
|
||
|
|
s7_int s7_vector_dimension(s7_pointer vec, s7_int dim);
|
||
|
|
s7_pointer *s7_vector_elements(s7_pointer vec);
|
||
|
|
s7_int s7_vector_dimensions(s7_pointer vec, s7_int *dims, s7_int dims_size);
|
||
|
|
s7_int s7_vector_offsets(s7_pointer vec, s7_int *offs, s7_int offs_size);
|
||
|
|
|
||
|
|
void s7_vector_fill(s7_scheme *sc, s7_pointer vec, s7_pointer obj);
|
||
|
|
s7_pointer s7_vector_copy(s7_scheme *sc, s7_pointer old_vect);
|
||
|
|
s7_pointer s7_vector_to_list(s7_scheme *sc, s7_pointer vect);
|
||
|
|
|
||
|
|
s7_pointer s7_make_int_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info);
|
||
|
|
s7_int *s7_int_vector_elements(s7_pointer vec);
|
||
|
|
bool s7_is_int_vector(s7_pointer p);
|
||
|
|
s7_int s7_int_vector_ref(s7_pointer vec, s7_int index);
|
||
|
|
s7_int s7_int_vector_set(s7_pointer vec, s7_int index, s7_int value);
|
||
|
|
|
||
|
|
s7_pointer s7_make_float_vector(s7_scheme *sc, s7_int len, s7_int dims, s7_int *dim_info);
|
||
|
|
s7_pointer s7_make_float_vector_wrapper(s7_scheme *sc, s7_int len, s7_double *data, s7_int dims, s7_int *dim_info, bool free_data);
|
||
|
|
s7_double *s7_float_vector_elements(s7_pointer vec);
|
||
|
|
bool s7_is_float_vector(s7_pointer p);
|
||
|
|
s7_double s7_float_vector_ref(s7_pointer vec, s7_int index);
|
||
|
|
s7_double s7_float_vector_set(s7_pointer vec, s7_int index, s7_double value);
|
||
|
|
|
||
|
|
s7_pointer s7_vector_ref(s7_scheme *sc, s7_pointer vec, s7_int index);
|
||
|
|
s7_pointer s7_vector_set(s7_scheme *sc, s7_pointer vec, s7_int index, s7_pointer a);
|
||
|
|
s7_pointer s7_vector_ref_n(s7_scheme *sc, s7_pointer vector, s7_int indices, ...);
|
||
|
|
s7_pointer s7_vector_set_n(s7_scheme *sc, s7_pointer vector, s7_pointer value, s7_int indices, ...);
|
||
|
|
</pre>
|
||
|
|
<p>s7_make_vector returns a one-dimensional vector of the given length;
|
||
|
|
its elements are initialized to the empty list, ().
|
||
|
|
s7_make_and_fill_vector is similar, but the initial element is set by
|
||
|
|
the "fill" parameter. This value
|
||
|
|
is simply placed in every vector location, not copied, so if you pass a
|
||
|
|
cons, then change its car,
|
||
|
|
that change is reflected in every element of the vector.
|
||
|
|
s7_make_normal_vector returns a possibly multidimensional inhomogenous
|
||
|
|
vector (a "normal" vector, as opposed to an int-vector or a
|
||
|
|
float-vector).
|
||
|
|
</p>
|
||
|
|
<p>s7_is_vector is the same as vector?, s7_vector_length is length.
|
||
|
|
s7_vector_rank returns the number of dimensions in a vector, and s7_vector_dimension returns
|
||
|
|
the size of the given dimension. s7_vector_elements returns the s7_pointer array that holds
|
||
|
|
that vector's elements.
|
||
|
|
s7_vector_dimensions fills "dims" with the lengths of the corresponding dimensions.
|
||
|
|
s7_vector_offsets does the same for the successive dimensional offsets.
|
||
|
|
In a multidimensional vector, you can get the s7_vector_elements index by summing each index * offset[dimension].
|
||
|
|
s7_vector_to_list is vector->list. s7_vector_fill is fill! (as applied to a vector of course), and s7_vector_copy is copy.
|
||
|
|
</p>
|
||
|
|
<p>s7_make_int_vector returns an int-vector. Its elements are s7_ints (int64_t), and the array of s7_ints can be accessed
|
||
|
|
via s7_int_vector_elements. Similarly for float-vectors (the elements are s7_doubles which
|
||
|
|
are C doubles). s7_make_float_vector_wrapper provides a way to pass a C array of doubles
|
||
|
|
through scheme; it wraps up the array as a scheme float-vector. Both s7_make_int_vector
|
||
|
|
and s7_make_float_vector can return multidimensional vectors. The "dims" parameter specifies
|
||
|
|
the number of dimensions, and the "dim_info" parameter the individual dimensions. If dims
|
||
|
|
is 1, dim_info can be NULL. If the s7_make_float_vector_wrapper "free_data" parameter is true, s7 will free the "data"
|
||
|
|
array when the float-vector is garbage-collected. In ffitest.c, the g_block example calls:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">v1 = s7_make_float_vector_wrapper(sc, len, g1->data, 1, NULL, false);
|
||
|
|
</pre>
|
||
|
|
<p>when checking if two blocks are equivalent. Since this data is actually being shared
|
||
|
|
with a block object, we don't want s7 to free it when the g_blocks_are_equivalent function
|
||
|
|
is done. g1->data is freed by g_block_free when the c-object is garbage collected.
|
||
|
|
</p>
|
||
|
|
<p>s7_vector_ref and s7_vector_set apply to one-dimensional vectors; the "_n" cases
|
||
|
|
apply to multidimensional cases. All four functions can be used on any type of vector.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="ccpointers">C-pointers</div>
|
||
|
|
<pre class="indented">bool s7_is_c_pointer(s7_pointer arg);
|
||
|
|
bool s7_is_c_pointer_of_type(s7_pointer arg, s7_pointer type);
|
||
|
|
void *s7_c_pointer(s7_pointer p);
|
||
|
|
void *s7_c_pointer_with_type(s7_scheme *sc, s7_pointer p, s7_pointer expected_type, const char *caller, s7_int argnum);
|
||
|
|
s7_pointer s7_make_c_pointer(s7_scheme *sc, void *ptr);
|
||
|
|
s7_pointer s7_make_c_pointer_with_type(s7_scheme *sc, void *ptr, s7_pointer type, s7_pointer info);
|
||
|
|
s7_pointer s7_c_pointer_type(s7_pointer p);
|
||
|
|
</pre>
|
||
|
|
<p>These functions are equivalent to s7's c-pointer?, c-pointer, and c-pointer-type.
|
||
|
|
C-pointers in s7 are aimed primarily at passing uninterpreted C pointers through
|
||
|
|
s7 from one C function to another.
|
||
|
|
The "type" field can hold a type
|
||
|
|
indication, useful in debugging. s7_c_pointer_of_type checks that the c-pointer's
|
||
|
|
type field matches the type passed as the second argument. As a convenience,
|
||
|
|
s7_c_pointer_with_type combines s7_c_pointer with s7_is_c_pointer_of_type,
|
||
|
|
calling s7_error if the types don't match.
|
||
|
|
Nothing else in s7 assumes the type field is actually a type symbol, so you
|
||
|
|
can use the type and info fields for any purpose.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="cstrings">Strings</div>
|
||
|
|
|
||
|
|
<pre class="indented">bool s7_is_string(s7_pointer p);
|
||
|
|
const char *s7_string(s7_pointer p);
|
||
|
|
s7_pointer s7_make_string(s7_scheme *sc, const char *str);
|
||
|
|
s7_pointer s7_make_string_with_length(s7_scheme *sc, const char *str, s7_int len);
|
||
|
|
s7_pointer s7_make_string_wrapper(s7_scheme *sc, const char *str);
|
||
|
|
s7_pointer s7_make_permanent_string(s7_scheme *sc, const char *str);
|
||
|
|
s7_int s7_string_length(s7_pointer str);
|
||
|
|
</pre>
|
||
|
|
<p>These handle s7 strings. s7_is_string corresponds to scheme's string?,
|
||
|
|
and s7_string_length to scheme's string-length. s7_string returns the scheme string's value as a C string.
|
||
|
|
Don't free the returned string! s7_make_string takes a C string, and returns its scheme
|
||
|
|
equivalent. s7_make_string_with_length is the same, but it is faster because you pass the
|
||
|
|
new string's length (s7_make_string has to use strlen).
|
||
|
|
s7_make_permanent_string returns a scheme string that is not in the heap; it will never be GC'd.
|
||
|
|
s7_make_string_wrapper creates a temporary string. This saves the overhead of getting a free cell
|
||
|
|
from the heap and later GC-ing it, but the string may be reused at any time. It is useful as
|
||
|
|
an argument to s7_call and similar functions where you know no other strings will be needed
|
||
|
|
during that call.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="ccharacters">Characters</div>
|
||
|
|
|
||
|
|
<pre class="indented">bool s7_is_character(s7_pointer p);
|
||
|
|
uint8_t s7_character(s7_pointer p);
|
||
|
|
s7_pointer s7_make_character(s7_scheme *sc, uint8_t c);
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>s7_is_character is equivalent to character?. s7_character returns the unsigned char held by the s7 object p,
|
||
|
|
and s7_make_character returns an s7 object holding the unsigned char c.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="chashtables">Hash-tables</div>
|
||
|
|
|
||
|
|
<pre class="indented">bool s7_is_hash_table(s7_pointer p);
|
||
|
|
s7_pointer s7_make_hash_table(s7_scheme *sc, s7_int size);
|
||
|
|
s7_pointer s7_hash_table_ref(s7_scheme *sc, s7_pointer table, s7_pointer key);
|
||
|
|
s7_pointer s7_hash_table_set(s7_scheme *sc, s7_pointer table, s7_pointer key, s7_pointer value);
|
||
|
|
</pre>
|
||
|
|
<p>These functions are the C-side equivalent of hash-table?, make-hash-table, hash-table-ref,
|
||
|
|
and hash-table-set!.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="citerators">Iterators</div>
|
||
|
|
|
||
|
|
<pre class="indented">s7_pointer s7_make_iterator(s7_scheme *sc, s7_pointer e);
|
||
|
|
bool s7_is_iterator(s7_pointer obj);
|
||
|
|
bool s7_iterator_is_at_end(s7_scheme *sc, s7_pointer iter);
|
||
|
|
s7_pointer s7_iterate(s7_scheme *sc, s7_pointer iter);
|
||
|
|
</pre>
|
||
|
|
<p>These are the C equivalents of make-iterator, iterator?, iterator-at-end?, and iterate.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="chooks">Hooks</div>
|
||
|
|
<pre class="indented">s7_pointer s7_hook_functions(s7_scheme *sc, s7_pointer hook);
|
||
|
|
s7_pointer s7_hook_set_functions(s7_scheme *sc, s7_pointer hook, s7_pointer functions);
|
||
|
|
</pre>
|
||
|
|
<p>These access the list of functions associated with a hook. See <a href="#hooks">hooks</a>
|
||
|
|
for a discussion of hooks, and <a href="#testhook">C and Scheme Hooks</a> for a short example.
|
||
|
|
The scheme equivalent is hook-functions (a dilambda).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="cconstants">Constants</div>
|
||
|
|
<pre class="indented">s7_pointer s7_f(s7_scheme *sc);
|
||
|
|
s7_pointer s7_t(s7_scheme *sc);
|
||
|
|
s7_pointer s7_nil(s7_scheme *sc);
|
||
|
|
s7_pointer s7_undefined(s7_scheme *sc);
|
||
|
|
s7_pointer s7_unspecified(s7_scheme *sc);
|
||
|
|
s7_pointer s7_eof_object(s7_scheme *sc);
|
||
|
|
|
||
|
|
bool s7_is_unspecified(s7_scheme *sc, s7_pointer val);
|
||
|
|
bool s7_is_null(s7_scheme *sc, s7_pointer p);
|
||
|
|
bool s7_is_boolean(s7_pointer x);
|
||
|
|
|
||
|
|
bool s7_boolean(s7_scheme *sc, s7_pointer x);
|
||
|
|
s7_pointer s7_make_boolean(s7_scheme *sc, bool x);
|
||
|
|
|
||
|
|
bool s7_is_immutable(s7_pointer p);
|
||
|
|
s7_pointer s7_immutable(s7_pointer p);
|
||
|
|
</pre>
|
||
|
|
<p>These return the standard scheme or s7 constants: #f, #t, (), #<undefined>, #<unspecified>, and #<eof>.
|
||
|
|
Also the s7 function unspecified?, and the scheme functions null?, and boolean?. s7_make_boolean
|
||
|
|
returns #t or #f depending on its argument.
|
||
|
|
</p>
|
||
|
|
<p>s7_immutable makes its argument immutable, and s7_is_immutable returns true if its argument is immutable.
|
||
|
|
They parallel s7's immutable! and immutable?.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="coptimizations">Optimization</div>
|
||
|
|
|
||
|
|
<pre class="indented">typedef s7_double (*s7_d_t)(void);
|
||
|
|
void s7_set_d_function(s7_scheme *sc, s7_pointer f, s7_d_t df);
|
||
|
|
s7_d_t s7_d_function(s7_pointer f);
|
||
|
|
etc...
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
These functions tell s7 to call a foreign function directly, without any scheme-related
|
||
|
|
overhead. The function to be called in this manner needs to take the form of one of the s7_*_t functions in s7.h.
|
||
|
|
For example,
|
||
|
|
one way to call + is to pass it two s7_double arguments and get an s7_double back. This is the
|
||
|
|
s7_d_dd_t function (the first letter gives the return type, the rest give successive argument types,
|
||
|
|
d=double, i=integer, v=c_object, p=s7_pointer).
|
||
|
|
We tell s7 about it via s7_set_d_dd_function. Whenever s7's optimizer encounters + with two arguments
|
||
|
|
that it (the optimizer) knows are s7_doubles, in a context where an s7_double result is expected,
|
||
|
|
s7 calls the associated s7_d_dd_t function directly without preparing a list of arguments, and without
|
||
|
|
wrapping up the result as an s7 object.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Here is an example of using these functions; more extensive examples are in clm2xen.c in sndlib, and in s7.c.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">static s7_pointer g_plus_one(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
return(s7_make_integer(sc, s7_integer(s7_car(args)) + 1));
|
||
|
|
}
|
||
|
|
|
||
|
|
static s7_int plus_one(s7_int x) {return(x + 1);}
|
||
|
|
|
||
|
|
s7_define_safe_function(sc, "plus1", g_plus_one, 1, 0, false, "");
|
||
|
|
s7_set_i_i_function(sc, s7_name_to_value(sc, "plus1"), plus_one);
|
||
|
|
</pre>
|
||
|
|
<p>s7_define_safe_function defines a Scheme function "plus1",
|
||
|
|
telling the optimizer that this function is safe.
|
||
|
|
A safe function does not push anything on the s7 stack, and treats the arglist
|
||
|
|
passed to it as immutable and temporary (that is, it just grabs the arguments from
|
||
|
|
the list). A few s7_* functions are unsafe, and that makes anything that calls
|
||
|
|
them also unsafe. If the optimizer knows a function is safe, it can use prebuilt
|
||
|
|
lists to pass the arguments (saving in the GC), and can combine it in various
|
||
|
|
ways with other stuff. If an unsafe function handles its argument list safely,
|
||
|
|
declare it with s7_define_semisafe_typed_function.
|
||
|
|
If the safe function knows its return and argument
|
||
|
|
types, there is another level of optimization that can call it without
|
||
|
|
setting up an arglist or "unboxing" values, basically a direct call in C.
|
||
|
|
In this example, the s7_set_i_i_function call
|
||
|
|
tells the optimizer that if plus1 is seen in a context where the optimizer
|
||
|
|
knows it is receiving an s7_int argument, and is expected to return
|
||
|
|
an s7_int result, it can call plus_one directly, rather than g_plus_one.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>There are more of these functions in s7.c that could be exported via s7.h
|
||
|
|
if you need them.
|
||
|
|
</p>
|
||
|
|
<p>By the way, to optimize scheme code (for speed), first use functions: the optimizer
|
||
|
|
ignores anything else at the top level. Then perhaps check lint.scm and the profiler.
|
||
|
|
Don't use something dumb like call/cc. Avoid append. Use iteration, not recursion.
|
||
|
|
Perhaps take the hot spot and do it in C. callgrind might also be helpful, but it
|
||
|
|
can be hard to map from callgrind output to the original scheme code.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="shortheader" id="candsoon">And so on...</div>
|
||
|
|
|
||
|
|
<pre class="indented">s7_scheme *s7_init(void);
|
||
|
|
void s7_quit(s7_scheme *sc);
|
||
|
|
void s7_free(s7_scheme *sc);
|
||
|
|
void s7_repl(s7_scheme *sc);
|
||
|
|
|
||
|
|
bool s7_is_eq(s7_pointer a, s7_pointer b);
|
||
|
|
bool s7_is_eqv(s7_scheme *sc, s7_pointer a, s7_pointer b);
|
||
|
|
bool s7_is_equal(s7_scheme *sc, s7_pointer a, s7_pointer b);
|
||
|
|
bool s7_is_equivalent(s7_scheme *sc, s7_pointer x, s7_pointer y);
|
||
|
|
|
||
|
|
void s7_provide(s7_scheme *sc, const char *feature);
|
||
|
|
bool s7_is_provided(s7_scheme *sc, const char *feature);
|
||
|
|
|
||
|
|
s7_pointer s7_stacktrace(s7_scheme *sc);
|
||
|
|
|
||
|
|
s7_pointer s7_history(s7_scheme *sc);
|
||
|
|
s7_pointer s7_add_to_history(s7_scheme *sc, s7_pointer entry);
|
||
|
|
bool s7_history_enabled(s7_scheme *sc);
|
||
|
|
bool s7_set_history_enabled(s7_scheme *sc, bool enabled);
|
||
|
|
|
||
|
|
s7_pointer s7_dynamic_wind(s7_scheme *sc, s7_pointer init, s7_pointer body, s7_pointer finish);
|
||
|
|
s7_pointer s7_make_continuation(s7_scheme *sc);
|
||
|
|
s7_pointer s7_values(s7_scheme *sc, s7_pointer args);
|
||
|
|
s7_pointer s7_copy(s7_scheme *sc, s7_pointer args);
|
||
|
|
s7_pointer s7_fill(s7_scheme *sc, s7_pointer args);
|
||
|
|
s7_pointer s7_type_of(s7_scheme *sc, s7_pointer arg);
|
||
|
|
s7_pfunc s7_optimize(s7_scheme *sc, s7_pointer expr);
|
||
|
|
bool s7_is_syntax(s7_pointer p);
|
||
|
|
bool s7_is_valid(s7_scheme *sc, s7_pointer arg);
|
||
|
|
|
||
|
|
void (*s7_begin_hook(s7_scheme *sc))(s7_scheme *sc, bool *val);
|
||
|
|
void s7_set_begin_hook(s7_scheme *sc, void (*hook)(s7_scheme *sc, bool *val));
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>s7_init creates a scheme interpreter. The returned value is the s7_scheme* used by many of the FFI functions.
|
||
|
|
s7_quit exits the interpreter. The memory allocated for it by s7_init is not freed unless you call s7_free.
|
||
|
|
(s7_free also frees its s7_scheme* argument).
|
||
|
|
s7_repl fires up a REPL.
|
||
|
|
s7_is_eq and friends correspond to scheme's eq?, eqv?, equal?, and equivalent?. s7_provide and s7_is_provided
|
||
|
|
add a symbol to the *features* list, or check for its presence there.
|
||
|
|
</p>
|
||
|
|
<p>s7_stacktrace is like stacktrace; it currently ignores (*s7* 'stacktrace).
|
||
|
|
The s7_history functions deal with the (*s7* 'history) buffer.
|
||
|
|
s7_dynamic_wind is dynamic-wind in C. The parameters "init", "body", and "finish" are
|
||
|
|
the same as in scheme (i.e. #f or a thunk). s7_make_continuation is call/cc; there
|
||
|
|
is an <a href="#signal">example</a> above.
|
||
|
|
s7_values is values, s7_copy is copy, s7_fill is fill!, s7_type_of is type-of, s7_is_syntax
|
||
|
|
is syntax?.
|
||
|
|
</p>
|
||
|
|
<p>s7_is_valid is a debugging aid; it tries to tell if an arbitrary value is pointing to
|
||
|
|
an s7 object. Set the compile-time switch TRAP_SEGFAULT to 1 before using this function!
|
||
|
|
</p>
|
||
|
|
<p>s7_optimize is the third-level optimizer. It is a bit hard to explain,
|
||
|
|
but basically you pass it some scheme code, and it returns either NULL or a function that can be called
|
||
|
|
to evaluate that code. There are several examples in snd-sig.c.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">static s7_pointer g_d_func(s7_scheme *sc, s7_pointer args)
|
||
|
|
{
|
||
|
|
/* a normal C-defined s7 function that simply returns (scheme) 1.0 */
|
||
|
|
return(s7_make_real(sc, 1.0));
|
||
|
|
}
|
||
|
|
static s7_double opt_d_func(void)
|
||
|
|
{
|
||
|
|
/* a version of g_d_func that returns (C) 1.0 */
|
||
|
|
return(1.0);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* now make it possible to call opt_d_func in place of g_d_func */
|
||
|
|
s7_float_function func;
|
||
|
|
s7_pointer symbol;
|
||
|
|
|
||
|
|
symbol = s7_define_safe_function(sc, "d-func", g_d_func, 0, 0, false, "opt func");
|
||
|
|
s7_set_d_function(sc, s7_name_to_value(sc, "d-func"), opt_d_func);
|
||
|
|
|
||
|
|
/* and try it (this saves creating an s7 real, accessing its value, and GC-ing it eventually) */
|
||
|
|
func = s7_float_optimize(sc, s7_list(sc, 1, s7_list(sc, 1, symbol)));
|
||
|
|
fprintf(stderr, "%f\n", func(sc));
|
||
|
|
</pre>
|
||
|
|
<p>
|
||
|
|
Finally, the begin_hook
|
||
|
|
functions are explained <a href="#beginhook">above</a>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<br><br>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="topheader" id="s7examples">s7 examples</div>
|
||
|
|
|
||
|
|
<p>The s7 tarball includes several scheme files:
|
||
|
|
</p>
|
||
|
|
<ul>
|
||
|
|
<li>case.scm provides case*, an extension of case for pattern matching
|
||
|
|
</li><li>cload.scm is a wrapper for the FFI stuff described above
|
||
|
|
</li><li>debug.scm provides various debugging aids such as trace, break, and watch
|
||
|
|
</li><li>json.scm is a JSON reader/writer, but I got side-tracked
|
||
|
|
</li><li>lint.scm is the s7 equivalent of the ancient C program named lint (modern equivalent: cppcheck)
|
||
|
|
</li><li>loop.scm is Rick Taube's CL loop macro
|
||
|
|
</li><li>mockery.scm has mock data libraries (openlets masquerading as various data types)
|
||
|
|
</li><li>profile.scm is a profiler
|
||
|
|
</li><li>r7rs.scm implements some of r7rs-small
|
||
|
|
</li><li>reactive.scm implements some reactive programming macros (set!, let)
|
||
|
|
</li><li>repl.scm is a vt-100 based repl
|
||
|
|
</li><li>nrepl.scm is a notcurses based repl
|
||
|
|
</li><li>s7test.scm is a regression test for s7
|
||
|
|
</li><li>stuff.scm is just some arbitrary stuff
|
||
|
|
</li><li>write.scm has a pretty printer
|
||
|
|
</li></ul>
|
||
|
|
<p>
|
||
|
|
libc.scm, libgsl.scm, libm.scm, libdl.scm, notcurses_s7.c, libutf8proc.scm, and libgdbm.scm tie the associated
|
||
|
|
libraries into s7.
|
||
|
|
gdbinit has some gdb commands for s7.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="cload"><h4>cload.scm</h4></div>
|
||
|
|
|
||
|
|
<p>cload.scm defines the macro c-define that reduces the overhead
|
||
|
|
involved in (dynamically) linking C entities into s7.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(<em class="def" id="definecfunction">c-define</em> c-info (prefix "") (headers ()) (cflags "") (ldflags "") output-name)
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>For example, <code>(c-define '(double j0 (double)) "m" "math.h")</code>
|
||
|
|
links the C math library function j0 into s7 under the name m:j0,
|
||
|
|
passing it a double argument and getting a double result (a real in s7).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p><em>prefix</em> is some arbitrary prefix that you want prepended to various names.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p><em>headers</em> is a list of headers (as strings) that the c-info relies on, (("math.h") for example).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p><em>cflags</em> are any special C compiler flags that are needed ("-I." in particular), and
|
||
|
|
<em>ldflags</em> is the similar case for the loader. <em>output-name</em> is the name of the
|
||
|
|
output C file and associated library. It defaults to "temp-s7-output" followed by a number.
|
||
|
|
In libm.scm, it is set to "libm_s7" to protect it across cload calls. If cload finds an
|
||
|
|
up-to-date output C file and shared library, it simply loads the library, rather than
|
||
|
|
going through all the trouble of writing and compling it.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p><em>c-info</em> is a list that describes the C entities that you want to load into s7.
|
||
|
|
It can be either one list describing one entity, or a list of such lists.
|
||
|
|
Each description has the form:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(return-type entity-name-in-C (argument-type...))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>where each entry is a symbol, and C names are used throughout. So, in the j0
|
||
|
|
example above, <code>(double j0 (double))</code> says we want access to j0, it returns
|
||
|
|
a C double, and it takes one argument, also a C double. s7 tries to figure out
|
||
|
|
what the corresponding s7 type is, but in tricky cases, you should tell it
|
||
|
|
by replacing the bare type name with a list: <code>(C-type underlying-C-type)</code>. For example,
|
||
|
|
the Snd function set_graph_style takes an (enum) argument of type graph_style_t.
|
||
|
|
This is actually an int, so we use <code>(graph_style_t int)</code> as the type:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(void set_graph_style ((graph_style_t int)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>If the C entity is a constant, then the descriptor list has just two entries,
|
||
|
|
the C-type and the entity name: <code>(int F_OK)</code> for example. The entity name can also be a list:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">((graph_style_t int) (GRAPH_LINES GRAPH_DOTS GRAPH_FILLED GRAPH_DOTS_AND_LINES GRAPH_LOLLIPOPS))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>This defines all the names in the list as integers.
|
||
|
|
If the C type has a space ("struct tm*"), use <code>(symbol "struct tm*")</code>
|
||
|
|
to construct the corresponding symbol.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>The entity is placed in the current s7 environment under the name <code>(string-append prefix ":" name)</code>
|
||
|
|
where the ":" is omitted if the prefix is null. So in the j0 example, we get in s7 the function m:j0.
|
||
|
|
c-define returns #t if it thinks the load worked, and #f otherwise.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>There are times when the only straightforward approach is to write the desired
|
||
|
|
C code directly. To insert C code on the fly, use (in-C "code..."). Two more such
|
||
|
|
cases that come up all the time: C-function for linkage to functions written
|
||
|
|
directly in s7 style using in-C, and C-macro for macros in the C header file that
|
||
|
|
need to be wrapped in #ifdefs.
|
||
|
|
Here are some examples:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">;;; various math library functions
|
||
|
|
(c-define '((double j0 (double))
|
||
|
|
(double j1 (double))
|
||
|
|
(double erf (double))
|
||
|
|
(double erfc (double))
|
||
|
|
(double lgamma (double)))
|
||
|
|
"m" "math.h")
|
||
|
|
|
||
|
|
|
||
|
|
;;; getenv and setenv
|
||
|
|
(c-define '(char* getenv (char*)))
|
||
|
|
(c-define '(int setenv (char* char* int)))
|
||
|
|
|
||
|
|
|
||
|
|
;;; file-exists? and delete-file
|
||
|
|
(define file-exists? (let () ; define F_OK and access only within this let
|
||
|
|
(c-define '((int F_OK) (int access (char* int))) "" "unistd.h")
|
||
|
|
(lambda (arg) (= (access arg F_OK) 0))))
|
||
|
|
|
||
|
|
(define delete-file (let ()
|
||
|
|
(c-define '(int unlink (char*)) "" "unistd.h")
|
||
|
|
(lambda (file) (= (unlink file) 0)))) ; 0=success
|
||
|
|
|
||
|
|
|
||
|
|
;;; examples from Snd:
|
||
|
|
(c-define '(char* version_info ()) "" "snd.h" "-I.")
|
||
|
|
|
||
|
|
(c-define '(mus_float_t mus_degrees_to_radians (mus_float_t)) "" "snd.h" "-I.")
|
||
|
|
|
||
|
|
(c-define '(snd_info* any_selected_sound ()) "" "snd.h" "-I.")
|
||
|
|
(c-define '(void select_channel (snd_info* int)) "" "snd.h" "-I.")
|
||
|
|
|
||
|
|
(c-define '(((graph_style_t int) (GRAPH_LINES GRAPH_DOTS GRAPH_FILLED GRAPH_DOTS_AND_LINES GRAPH_LOLLIPOPS))
|
||
|
|
(void set_graph_style ((graph_style_t int))))
|
||
|
|
"" "snd.h" "-I.")
|
||
|
|
|
||
|
|
|
||
|
|
;;; getcwd, strftime
|
||
|
|
(c-define '(char* getcwd (char* size_t)) "" "unistd.h")
|
||
|
|
|
||
|
|
(c-define (list '(void* calloc (size_t size_t))
|
||
|
|
'(void free (void*))
|
||
|
|
'(void time (time_t*)) ; ignore returned value
|
||
|
|
(list (symbol "struct tm*") 'localtime '(time_t*))
|
||
|
|
(list 'size_t 'strftime (list 'char* 'size_t 'char* (symbol "struct tm*"))))
|
||
|
|
"" "time.h")
|
||
|
|
|
||
|
|
> (let ((p (calloc 1 8))
|
||
|
|
(str (make-string 32)))
|
||
|
|
(time p)
|
||
|
|
(strftime str 32 "%a %d-%b-%Y %H:%M %Z" (localtime p))
|
||
|
|
(free p)
|
||
|
|
str)
|
||
|
|
<em class="gray">"Sat 11-Aug-2012 08:55 PDT\x00 "</em>
|
||
|
|
|
||
|
|
|
||
|
|
;;; opendir, read_dir, closedir
|
||
|
|
(c-define '((int closedir (DIR*))
|
||
|
|
(DIR* opendir (char*))
|
||
|
|
(in-C "static char *read_dir(DIR *p) \
|
||
|
|
{ \
|
||
|
|
struct dirent *dirp; \
|
||
|
|
dirp = readdir(p); \
|
||
|
|
if (!dirp) return(NULL); \
|
||
|
|
return(dirp->d_name); \
|
||
|
|
}")
|
||
|
|
(char* read_dir (DIR*)))
|
||
|
|
"" '("sys/types.h" "dirent.h"))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>C-init inserts its string argument into the initialization section of
|
||
|
|
the module. In libgsl.scm, for example,
|
||
|
|
</p>
|
||
|
|
<pre class="inserted">(C-init "gsl_set_error_handler(g_gsl_error);")
|
||
|
|
</pre>
|
||
|
|
<p>inserts that string (as C code) into libgsl_s7.c toward the beginning of the
|
||
|
|
libgsl_s7_init function (line 42346 or so).
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>When compiling, for the simple cases above, include "-ldl -Wl,-export-dynamic" in the gcc command. So the first
|
||
|
|
FFI example is built (this is in Linux):
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">gcc -c s7.c -I.
|
||
|
|
gcc -o ex1 ex1.c s7.o -lm -I. -ldl -Wl,-export-dynamic
|
||
|
|
ex1
|
||
|
|
> (load "cload.scm")
|
||
|
|
<em class="gray">c-define-1</em>
|
||
|
|
> (c-define '(double j0 (double)) "m" "math.h")
|
||
|
|
<em class="gray">#t</em>
|
||
|
|
> (m:j0 0.5)
|
||
|
|
<em class="gray">0.93846980724081</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>See also r7rs.scm, libc.scm, libgsl.scm, libm.scm, libdl.scm, and libgdbm.scm.
|
||
|
|
libutf8proc.scm exists, but I have not tested it at all.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>The default in the lib*.scm files is to use the C name as the Scheme name.
|
||
|
|
This collides with (for example) the widespread use of "-", rather than "_" in Scheme, but
|
||
|
|
I have found it much more straightforward to stick with one name. In cases like
|
||
|
|
libgsl there are thousands of names, all documented at great length
|
||
|
|
by the C name. Anyone who wants to use these functions has to start with the C name.
|
||
|
|
If they are forced to fuss with some annoying Schemely translation of it,
|
||
|
|
the only sane response is: "forget it! I'll do it in C".
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="indented" id="libc">
|
||
|
|
<pre>(require libc.scm)
|
||
|
|
|
||
|
|
(define (copy-file in-file out-file)
|
||
|
|
(with-let (sublet *libc* :in-file in-file :out-file out-file)
|
||
|
|
|
||
|
|
;; the rest of the function body exists in the *libc* environment, with the
|
||
|
|
;; function parameters in-file and out-file imported, so, for example,
|
||
|
|
;; (open ...) below calls the libc function open.
|
||
|
|
|
||
|
|
(let ((infd (open in-file O_RDONLY 0)))
|
||
|
|
(if (= infd -1)
|
||
|
|
(error 'io-error "can't find ~S~%" in-file)
|
||
|
|
(let ((outfd (creat out-file #o666)))
|
||
|
|
(if (= outfd -1)
|
||
|
|
(begin
|
||
|
|
(close infd)
|
||
|
|
(error 'io-error "can't open ~S~%" out-file))
|
||
|
|
(let* ((BUF_SIZE 1024)
|
||
|
|
(buf (malloc BUF_SIZE)))
|
||
|
|
(do ((num (read infd buf BUF_SIZE) (read infd buf BUF_SIZE)))
|
||
|
|
((or (<= num 0)
|
||
|
|
(not (= (write outfd buf num) num)))))
|
||
|
|
(close outfd)
|
||
|
|
(close infd)
|
||
|
|
(free buf)
|
||
|
|
out-file)))))))
|
||
|
|
|
||
|
|
(define (glob->list pattern)
|
||
|
|
(with-let (sublet *libc* :pattern pattern)
|
||
|
|
(let ((g (glob.make)))
|
||
|
|
(glob pattern 0 g)
|
||
|
|
(let ((res (glob.gl_pathv g)))
|
||
|
|
(globfree g)
|
||
|
|
res))))
|
||
|
|
|
||
|
|
;; now (load "*.scm") is (for-each load (glob->list "*.scm"))
|
||
|
|
|
||
|
|
;; a couple regular expression examples
|
||
|
|
(with-let (sublet *libc*)
|
||
|
|
(define rg (regex.make))
|
||
|
|
(regcomp rg "a.b" 0)
|
||
|
|
(display (regexec rg "acb" 0 0)) (newline) ; 0 = match
|
||
|
|
(regfree rg))
|
||
|
|
|
||
|
|
(with-let (sublet *libc*)
|
||
|
|
(define rg (regex.make))
|
||
|
|
(let ((res (regcomp rg "colou\\?r" 0)))
|
||
|
|
(if (not (zero? res))
|
||
|
|
(error 'regex-error "~S: ~S~%" "colou\\?r" (regerror res rg)))
|
||
|
|
(set! res (regexec rg "The color green" 1 0))
|
||
|
|
(display res) (newline) ; #i(4 9) = match start/end
|
||
|
|
(regfree rg)))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="indented" id="libgsl">
|
||
|
|
<pre>(require libgsl.scm)
|
||
|
|
|
||
|
|
(define (eigenvalues M)
|
||
|
|
(with-let (sublet *libgsl* :M M)
|
||
|
|
(let* ((len (sqrt (length M)))
|
||
|
|
(gm (gsl_matrix_alloc len len))
|
||
|
|
(m (float-vector->gsl_matrix M gm))
|
||
|
|
(evl (gsl_vector_complex_alloc len))
|
||
|
|
(evc (gsl_matrix_complex_alloc len len))
|
||
|
|
(w (gsl_eigen_nonsymmv_alloc len)))
|
||
|
|
|
||
|
|
(gsl_eigen_nonsymmv m evl evc w)
|
||
|
|
(gsl_eigen_nonsymmv_free w)
|
||
|
|
(gsl_eigen_nonsymmv_sort evl evc GSL_EIGEN_SORT_ABS_DESC)
|
||
|
|
|
||
|
|
(let ((vals (make-vector len)))
|
||
|
|
(do ((i 0 (+ i 1)))
|
||
|
|
((= i len))
|
||
|
|
(set! (vals i) (gsl_vector_complex_get evl i)))
|
||
|
|
(gsl_matrix_free gm)
|
||
|
|
(gsl_vector_complex_free evl)
|
||
|
|
(gsl_matrix_complex_free evc)
|
||
|
|
vals))))
|
||
|
|
</pre>
|
||
|
|
</div>
|
||
|
|
|
||
|
|
<p>We can use gdbm (or better yet, mdb), the :readable argument to object->string, and
|
||
|
|
the fallback methods in the environments to create name-spaces (lets) with billions of
|
||
|
|
thread-safe local variables, which can be saved and communicated between s7 runs:
|
||
|
|
</p>
|
||
|
|
<div class="indented" id="libgdbm">
|
||
|
|
<pre>(require libgdbm.scm)
|
||
|
|
|
||
|
|
(with-let *libgdbm*
|
||
|
|
|
||
|
|
(define *db*
|
||
|
|
(openlet
|
||
|
|
(inlet :file (gdbm_open "test.gdbm" 1024 GDBM_NEWDB #o664
|
||
|
|
(lambda (str) (format *stderr* "gdbm error: ~S~%" str)))
|
||
|
|
|
||
|
|
:let-ref-fallback (lambda (obj sym)
|
||
|
|
(eval-string (gdbm_fetch (obj 'file) (symbol->string sym))))
|
||
|
|
|
||
|
|
:let-set-fallback (lambda (obj sym val)
|
||
|
|
(gdbm_store (obj 'file)
|
||
|
|
(symbol->string sym)
|
||
|
|
(object->string val :readable)
|
||
|
|
GDBM_REPLACE)
|
||
|
|
val)
|
||
|
|
|
||
|
|
:make-iterator (lambda (obj)
|
||
|
|
(let ((key #f)
|
||
|
|
(length (lambda (obj) (expt 2 20))))
|
||
|
|
(#_make-iterator
|
||
|
|
(let ((+iterator+ #t))
|
||
|
|
(openlet
|
||
|
|
(lambda ()
|
||
|
|
(if key
|
||
|
|
(set! key (gdbm_nextkey (obj 'file) (cdr key)))
|
||
|
|
(set! key (gdbm_firstkey (obj 'file))))
|
||
|
|
(if (pair? key)
|
||
|
|
(cons (string->symbol (car key))
|
||
|
|
(eval-string (gdbm_fetch (obj 'file) (car key))))
|
||
|
|
key))))))))))
|
||
|
|
|
||
|
|
(set! (*db* 'str) "123") ; add a variable named 'str with the value "123"
|
||
|
|
(set! (*db* 'int) 432)
|
||
|
|
|
||
|
|
(with-let *db*
|
||
|
|
(+ int (length str))) ; -> 435
|
||
|
|
(map values *db*) ; -> '((str . "123") (int . 432))
|
||
|
|
|
||
|
|
(gdbm_close (*db* 'file)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<!-- the overhead of using a data-base is not negligible, although libgdbm is probably not the fastest.
|
||
|
|
A bare set/ref 200000 times is .002 secs, via let-ref is .005, but via the data-base is .184.
|
||
|
|
Presumably thread globals won't be in inner loops, so even this looks ok, say 1 million / second.
|
||
|
|
-->
|
||
|
|
</div>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="case"><h4>case.scm</h4></div>
|
||
|
|
|
||
|
|
<p>case.scm has case*, a compatible extension of case that includes pattern matching.
|
||
|
|
<code>(case* selector ((target...) body) ...)</code> uses equivalent? to match the
|
||
|
|
selector to the targets, evaluating the body associated with the first matching target.
|
||
|
|
If a target is a list or vector, the elements are checked item by item.
|
||
|
|
Each target, or element of a list or vector can be a pattern. Patterns
|
||
|
|
are of the form #<whatever> (undefined constants from s7's pointer of view).
|
||
|
|
A pattern can be:
|
||
|
|
</p>
|
||
|
|
<pre><ul>
|
||
|
|
<li>#<> any expr matches
|
||
|
|
</li><li>#<func> expr matches if (func expr)
|
||
|
|
</li><li>#<label:func> expr matches as above, expr is saved under "label"
|
||
|
|
</li><li>#<label:> any expr matches, and is saved under "label"
|
||
|
|
</li><li>#<label> expr must match the value saved under "label"
|
||
|
|
</li><li>#<...> skip exprs covered by the ellipsis
|
||
|
|
</li><li>#<label:...> skip as above, saved skipped exprs under "label" as a quoted list.
|
||
|
|
</li><li> a pattern can have any number of labelled ellipses overall,
|
||
|
|
</li><li> but just one unnamed ellipsis, and only one ellipsis per pair or vector
|
||
|
|
</li><li>#<label,func:...> a labelled ellipsis which matches if (func expr); expr is the ellipsis list,
|
||
|
|
</li><li> label is not optional in this case
|
||
|
|
</li><li>#<"regexp"> pattern is a regular expression to be matched against a string
|
||
|
|
</li><li>#<label:"regexp"> a labelled regular expression
|
||
|
|
</li></ul>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>If a label occurs in the result body, the expression it labelled is substituted for it.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(case* x ((3.14) 'pi)) ; returns 'pi if x is 3.14
|
||
|
|
|
||
|
|
(case* x ((#<symbol?>))) ; returns #t if x is a symbol
|
||
|
|
|
||
|
|
(case* x (((+ 1 #<symbol?>)))) ; matches any list of the form '(+ 1 x) or any symbol in place of "x"
|
||
|
|
|
||
|
|
(case* x (((#<symbol?> #<e1:...> (+ #<e2:...>)))
|
||
|
|
(append #<e1> #<e2>))) ; passed '(a b c d (+ 1 2)), returns '(b c d 1 2)
|
||
|
|
|
||
|
|
(case* x ((#<"a.b">))) ; matches if x is a string "a.b" where "." matches anything
|
||
|
|
|
||
|
|
(define (palindrome? x)
|
||
|
|
(case* x
|
||
|
|
((() (#<>))
|
||
|
|
#t)
|
||
|
|
(((#<start:> #<middle:...> #<start>))
|
||
|
|
(palindrome? #<middle>))
|
||
|
|
(else #f)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>case*'s matching function can be used anywhere.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(let ((match? ((funclet 'case*) 'case*-match?))) ; this is case*'s matcher
|
||
|
|
(match? x '(+ #<symbol?> 1))) ; returns #t if x is of the form '(+ x 1), x any symbol
|
||
|
|
|
||
|
|
(define match+
|
||
|
|
(let ((match? ((funclet 'case*) 'case*-match?))
|
||
|
|
(labels ((funclet 'case*) 'case*-labels))) ; these are the labels and their values
|
||
|
|
(macro (arg)
|
||
|
|
(cond ((null? arg) ())
|
||
|
|
((match? arg '(+ #<a:> (+ #<b:...>))) `(+ ,(labels 'a) ,@(cadr (labels 'b))))
|
||
|
|
((match? arg '(+ #<> #<>)) `(+ ,@(cdr arg)))
|
||
|
|
(else #f)))))
|
||
|
|
|
||
|
|
;; (match+ (+ 1 (+ 2 3))) -> 6
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>See case.scm and s7test.scm for many more examples, including let and hash-table matching.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="debug"><h4>debug.scm</h4></div>
|
||
|
|
|
||
|
|
<p>debug.scm has various debugging aids, including trace, break, watch, and a C-style stacktrace.
|
||
|
|
The *s7* field 'debug controls when these are active, and to what extent.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>(<em class="emdef">trace</em> func) adds a tracepoint to the start of the function or macro func.
|
||
|
|
(trace) adds such tracing to every subsequently defined function or macro.
|
||
|
|
(<em class="emdef">untrace</em>) turns off tracing; (untrace func) turns off tracing in func.
|
||
|
|
Similarly (<em class="emdef">break</em> func) places a breakpoint at the start of func,
|
||
|
|
(<em class="emdef">unbreak</em> func) removes it. (unbreak) removes all breakpoints.
|
||
|
|
When a breakpoint is encountered, you are placed in a repl at
|
||
|
|
that point; type C-q to continue. To trace a variable, use
|
||
|
|
(<em class="emdef">watch</em> var). watch reports whenever var is set! and
|
||
|
|
(<em class="emdef">unwatch</em> var) removes the watchpoint.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
These trace, break and watchpoints are active
|
||
|
|
only if <em class="emdef">(*s7* 'debug)</em> is positive. If 'debug is 1, existing traces
|
||
|
|
and breaks are active, but no new ones are added by s7. If 'debug
|
||
|
|
is 2, s7 adds tracepoints to any subsequently defined (i.e. named) functions and macros.
|
||
|
|
If (*s7* 'debug) is 3, unnamed functions are also traced.
|
||
|
|
If any tracing is enabled, you can get a C-style stacktrace by
|
||
|
|
setting (<em class="emdef">debug-stack</em>) to a vector, then
|
||
|
|
call (<em class="emdef">show-debug-stack</em>) to see the calls.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>
|
||
|
|
Besides debug-stack, debug.scm also defines the convenience functions
|
||
|
|
<em class="emdef">debug-function</em>, <em class="emdef">debug-port</em>, and
|
||
|
|
<em class="emdef">debug-repl</em>. debug-port is the debugger's
|
||
|
|
output port, debug-repl drops into a repl at a breakpoint, and debug-function
|
||
|
|
provides a way to customize the debugger's behavior.
|
||
|
|
The function <em class="emdef">debug-frame</em> provides a way to examine local variables.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">> (define (g1 x) (+ x 1))
|
||
|
|
<em class="gray">g1</em>
|
||
|
|
> (trace g1) ; this loads debug.scm unless it's already loaded, and sets (*s7* 'debug) to 1
|
||
|
|
<em class="gray">g1</em>
|
||
|
|
> (procedure-source g1) ; you can add trace-in explicitly (rather than call trace)
|
||
|
|
<em class="gray">(lambda (x) (trace-in (curlet)) (+ x 1))</em>
|
||
|
|
> (g1 2)
|
||
|
|
<em class="gray">(g1 2)</em> ; file/line info is included if relevant
|
||
|
|
<em class="gray"> -> 3
|
||
|
|
3</em>
|
||
|
|
> (break g1)
|
||
|
|
<em class="gray">g1</em>
|
||
|
|
> (g1 3)
|
||
|
|
<em class="gray">break: (g1 3), C-q to exit break
|
||
|
|
break> x</em> ; this is a repl started at the breakpoint
|
||
|
|
<em class="gray">3</em>
|
||
|
|
break> -> 4 ; C-q typed to exit the break
|
||
|
|
<em class="gray">4</em>
|
||
|
|
> (define var 1)
|
||
|
|
<em class="gray">1</em>
|
||
|
|
> (watch var)
|
||
|
|
<em class="gray">#<lambda (s v ...)></em> ; this is the new setter for 'var
|
||
|
|
> (set! var 3)
|
||
|
|
<em class="gray">var set! to 3
|
||
|
|
3</em>
|
||
|
|
> (define lt (inlet 'a 3))
|
||
|
|
<em class="gray">(inlet 'a 3)</em>
|
||
|
|
> (watch (lt 'a))
|
||
|
|
<em class="gray">#<lambda (s v ...)></em>
|
||
|
|
> (set! (lt 'a) 12)
|
||
|
|
<em class="gray">let-set! a to 12
|
||
|
|
12</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>s7test.scm has more examples</p>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
<div class="header" id="lint"><h4>lint.scm</h4></div>
|
||
|
|
|
||
|
|
<p>lint tries to find errors or infelicities in your scheme code.
|
||
|
|
To try it:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(load "lint.scm")
|
||
|
|
(lint "some-code.scm")
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
|
||
|
|
<p>
|
||
|
|
There are several
|
||
|
|
variables at the start of lint.scm to control additional output:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
|
||
|
|
<pre class="indented">*report-unused-parameters*
|
||
|
|
*report-unused-top-level-functions*
|
||
|
|
*report-shadowed-variables*
|
||
|
|
*report-undefined-identifiers*
|
||
|
|
*report-multiply-defined-top-level-functions*
|
||
|
|
*report-nested-if*
|
||
|
|
*report-short-branch*
|
||
|
|
*report-one-armed-if*
|
||
|
|
*report-loaded-files*
|
||
|
|
*report-any-!-as-setter*
|
||
|
|
*report-doc-strings*
|
||
|
|
*report-func-as-arg-arity-mismatch*
|
||
|
|
*report-bad-variable-names*
|
||
|
|
*report-built-in-functions-used-as-variables*
|
||
|
|
*report-forward-functions*
|
||
|
|
*report-sloppy-assoc*
|
||
|
|
*report-bloated-arg*
|
||
|
|
*report-clobbered-function-return-value*
|
||
|
|
*report-boolean-functions-misbehaving*
|
||
|
|
*report-repeated-code-fragments*
|
||
|
|
*report-quasiquote-rewrites*
|
||
|
|
*report-combinable-lets*
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>See lint.scm for more about these switches. You can also extend lint by adding your own code,
|
||
|
|
or adding your functions to lint's tables, or most simply by defining signatures for your functions.
|
||
|
|
snd-lint.scm performs these tasks for Snd. (lint exports its innards via *lint*).
|
||
|
|
lint is not smart about functions defined outside the current file, so *report-undefined-variables*
|
||
|
|
sometimes gets confused. You'll sometimes get a recommendation from lint that is less than helpful; nobody's perfect.
|
||
|
|
If it's actually wrong, and not just wrong-headed, please let me know.
|
||
|
|
Also in lint.scm are html-lint and C-lint. html-lint reads an HTML file looking for
|
||
|
|
Scheme code. If any is found, it runs s7 and then lint over it, reporting troubles.
|
||
|
|
Similarly C-lint reads a C file looking for s7_eval_c_string and running lint over its string.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="header" id="schemerepl"><h4>repl.scm and nrepl.scm</h4></div>
|
||
|
|
|
||
|
|
<p>There are three or four repls included with s7.
|
||
|
|
repl.scm is a textual interface based on vt-100 codes, and nrepl.scm is an
|
||
|
|
improvement of repl.scm based on the notcurses-core library.
|
||
|
|
I'll treat repl.scm first, then discuss how nrepl differs from it.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<p>repl.scm implements a repl using vt100 codes and libc.scm. It includes
|
||
|
|
symbol and filename completion, a history buffer, paren matching,
|
||
|
|
indentation, multi-line edits, and a debugger window.
|
||
|
|
To move around in the history buffer, use M-p, M-n or M-. (C-p and C-n are used to move the cursor in the current expression).
|
||
|
|
You can change the keymap or the prompt; all the repl functions are
|
||
|
|
accessible through the *repl* environment. One field is 'repl-let which
|
||
|
|
gives you access to all the repl's internal variables and functions.
|
||
|
|
Another is 'top-level-let, normally (sublet (rootlet)), which is the environment in
|
||
|
|
which the repl's evaluation takes place. You can reset the repl back to its
|
||
|
|
starting point with: <code>(set! (*repl* 'top-level-let) (sublet (rootlet)))</code>.
|
||
|
|
You can save the current repl state via <code>((*repl* 'save-repl))</code>, and
|
||
|
|
restore it later via <code>((*repl* 'restore-repl))</code>. The repl's saved state
|
||
|
|
is in the file save.repl, or the filename can be passed as an argument to save-repl and restore-repl.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>There is one annoying consequence of using (sublet (rootlet)) for the top-level let:
|
||
|
|
if you define something in the repl, then load a file that expects to find that thing
|
||
|
|
in rootlet, it won't:
|
||
|
|
</p>
|
||
|
|
<pre class="indented"><1> (define (func x) (+ x 1)) ; func is in (sublet (rootlet))
|
||
|
|
<em class="gray">func</em>
|
||
|
|
<2> (load "use-func.scm") ; file contents: (display (func 3))
|
||
|
|
<em class="red">error</em><em class="gray">: unbound variable func</em>
|
||
|
|
</pre>
|
||
|
|
<p>To get around this, either load the file into curlet: <code>(load "use-func.scm" (curlet))</code>,
|
||
|
|
or use with-let to place the definition in rootlet: <code>(with-let (curlet) (define (func x) (+ x 1)))</code>.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>Meta keys are a problem on the Mac. You can use ESC instead, but that requires
|
||
|
|
super-human capacities. I stared at replacement control keys, and nothing seemed
|
||
|
|
right. If you can think of something, it's easy to define replacements: see repl.scm
|
||
|
|
which has a small table of mappings.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>To run the repl, either build s7 with the compiler flag -DWITH_MAIN,
|
||
|
|
or conjure up a wrapper:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">#include "s7.h"
|
||
|
|
|
||
|
|
int main(int argc, char **argv)
|
||
|
|
{
|
||
|
|
s7_scheme *sc;
|
||
|
|
sc = s7_init();
|
||
|
|
s7_load(sc, "repl.scm");
|
||
|
|
s7_eval_c_string(sc, "((*repl* 'run))");
|
||
|
|
return(0);
|
||
|
|
}
|
||
|
|
|
||
|
|
/* gcc -o r r.c s7.o -Wl,-export-dynamic -lm -I. -ldl
|
||
|
|
*/
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Besides evaluating s7 expressions, like any repl,
|
||
|
|
you can also type shell commands just as in a shell:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented"><1> pwd
|
||
|
|
<em class="gray">/home/bil/cl</em>
|
||
|
|
<2> cd ..
|
||
|
|
<em class="gray">/home/bil</em>
|
||
|
|
<3> date
|
||
|
|
<em class="gray">Wed 15-Apr-2015 17:32:24 PDT</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>In most cases, these are handled through *unbound-variable-hook*, checked using "command -v", then passed
|
||
|
|
to the underlying shell via the system function.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>The prompt is set by the function (*repl* 'prompt). It gets one argument,
|
||
|
|
the current line number, and should set the prompt string and its length.
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(set! (*repl* 'prompt) (lambda (num)
|
||
|
|
(with-let (*repl* 'repl-let)
|
||
|
|
(set! prompt-string "scheme> ")
|
||
|
|
(set! prompt-length (length prompt-string)))))
|
||
|
|
</pre>
|
||
|
|
<p>or, to use the red lambda example mentioned earlier:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(set! (*repl* 'prompt)
|
||
|
|
(lambda (num)
|
||
|
|
(with-let (*repl* 'repl-let)
|
||
|
|
(set! prompt-string (bold (red (string #\xce #\xbb #\> #\space))))
|
||
|
|
(set! prompt-length 3)))) ; until we get unicode length calc
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>The line number provides a quick way to move around in the history buffer.
|
||
|
|
To get a previous line without laboriously typing M-p over and over,
|
||
|
|
simply type the line number (without control or meta bits), then M-.
|
||
|
|
In some CL repls, the special variable '* holds the last value computed.
|
||
|
|
In repl.scm, each value is retained in variables of the form '<n> where n
|
||
|
|
is the number shown in the prompt.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented"><1> (+ 1 2)
|
||
|
|
<em class="gray">3</em>
|
||
|
|
<2> (* <1> 2)
|
||
|
|
<em class="gray">6</em>
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Here is an example of adding to the keymap:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(set! ((*repl* 'keymap) (integer->char 17)) ; C-q to quit and return to caller
|
||
|
|
(lambda (c)
|
||
|
|
(set! ((*repl* 'repl-let) 'all-done) #t)))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>To access the meta keys (in the keymap), use a string:
|
||
|
|
<code>((*repl* 'keymap) (string #\escape #\p))</code>; this is Meta-p which normally accesses
|
||
|
|
the history buffer.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>You can call the repl from other code, poke around in the current environment (or whatever),
|
||
|
|
then return to the caller:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">(load "repl.scm")
|
||
|
|
|
||
|
|
(define (drop-into-repl e)
|
||
|
|
(let ((C-q (integer->char 17))) ; we'll use the C-q example above to get out
|
||
|
|
(let ((old-C-q ((*repl* 'keymap) C-q))
|
||
|
|
(old-top-level (*repl* 'top-level-let)))
|
||
|
|
(dynamic-wind
|
||
|
|
(lambda ()
|
||
|
|
(set! (*repl* 'top-level-let) e)
|
||
|
|
(set! ((*repl* 'keymap) C-q)
|
||
|
|
(lambda (c)
|
||
|
|
(set! ((*repl* 'repl-let) 'all-done) #t))))
|
||
|
|
(lambda ()
|
||
|
|
((<em class="red">*repl* 'run</em>))) ; run the repl
|
||
|
|
(lambda ()
|
||
|
|
(set! (*repl* 'top-level-let) old-top-level)
|
||
|
|
(set! ((*repl* 'keymap) C-q) old-C-q))))))
|
||
|
|
|
||
|
|
(let ((x 32))
|
||
|
|
(format *stderr* "x: ~A~%" x)
|
||
|
|
(<em class="red">drop-into-repl</em> (curlet))
|
||
|
|
(format *stderr* "now x: ~A~%" x))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Now load that code and:
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<pre class="indented">x: 32
|
||
|
|
<1> x
|
||
|
|
<em class="gray">32</em>
|
||
|
|
<2> (set! x 91)
|
||
|
|
<em class="gray">91</em>
|
||
|
|
<3> x
|
||
|
|
<em class="gray">91</em>
|
||
|
|
<4> now x: 91 ; here I typed C-q at the prompt
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>Another possibility:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">(set! (hook-functions *error-hook*)
|
||
|
|
(list (lambda (hook)
|
||
|
|
(apply format *stderr* (hook 'data))
|
||
|
|
(newline *stderr*)
|
||
|
|
(drop-into-repl (owlet)))))
|
||
|
|
</pre>
|
||
|
|
|
||
|
|
<p>See the end of repl.scm for more examples. See nrepl.scm for a better version of repl.scm.
|
||
|
|
Eventually I'll probably retire repl.scm.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<!--
|
||
|
|
(load "/home/bil/test/sndlib/libsndlib.so" (inlet 'init_func 's7_init_sndlib))
|
||
|
|
-->
|
||
|
|
|
||
|
|
|
||
|
|
<div class="separator"></div>
|
||
|
|
|
||
|
|
<p>Unlike repl, nrepl has support for the mouse, traversable, scrollable, and resizable panes, built-in ties to
|
||
|
|
lint.scm, debug.scm, and profile.scm, and various other enhancements.
|
||
|
|
Since it includes all the libc, notcurses FFI code, and nrepl.scm at compile-time, there
|
||
|
|
are no problems running it anywhere. To build nrepl:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">gcc -o nrepl s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl -DWITH_MAIN -DWITH_NOTCURSES -lnotcurses-core
|
||
|
|
</pre>
|
||
|
|
<p>If that is too easy, try:
|
||
|
|
</p>
|
||
|
|
<pre class="indented">gcc -c s7.c -O2 -I. -Wl,-export-dynamic -lm -ldl
|
||
|
|
gcc -o nrepl nrepl.c s7.o -lnotcurses-core -lm -I. -ldl
|
||
|
|
</pre>
|
||
|
|
<p>notcurses_s7.c needs version 2.1.6 or later of the notcurses-core library.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>When nrepl starts up, you have a prompt at the top of the terminal, and a status box
|
||
|
|
at the bottom. You can move around the pane via C-p and C-n (no need for repl.scm's M-p and M-n),
|
||
|
|
or use the mouse, or the arrow keys. If you set and hit a break point, a new pane is
|
||
|
|
opened in the context of the break. C-q exits the break. At the top pane, C-q exits
|
||
|
|
nrepl. C-g gives you another prompt (handy if you're caught in a messed up expression).
|
||
|
|
If you're in an infinite loop, C-c interrupts it. Otherwise C-c exits nrepl.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>If you set up a watcher (via watch from debug.scm), the action is displayed in
|
||
|
|
a separate box in the upper right corner. The status box displays all sorts of
|
||
|
|
informative and helpful messages, or at least that is the intent. lint.scm
|
||
|
|
checks each expression you type, and various hooks let you know when things
|
||
|
|
are happening in the background. Function signatures are posted there as well.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<p>You can customize nrepl in basically the same ways as described above for repl.scm.
|
||
|
|
You can also place these in a file named ".nrepl"; if nrepl finds such a file, it
|
||
|
|
loads it automatically at startup.
|
||
|
|
</p>
|
||
|
|
|
||
|
|
<br>
|
||
|
|
<blockquote>
|
||
|
|
<div class="indented">
|
||
|
|
<p>After months of intense typing,
|
||
|
|
Insanely declares his labors complete. "Ship it!" says Mr Big, and hands
|
||
|
|
him a million stock options. Meanwhile, in the basement behind an old door
|
||
|
|
with the eldritch sign "eep Ou", in a labyrinth of pounding pipes and fluorescent lights,
|
||
|
|
a forgotten shadow types <code>(lint "insanely-great.scm")</code>...
|
||
|
|
</p>
|
||
|
|
</div>
|
||
|
|
</blockquote>
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
</body></html>
|