geda-project/gerbvhtdocs
1
0
Fork 0
mirror of git://git.geda-project.org/gerbvhtdocs synced 2025-05-10 01:41:53 +08:00
Code Issues Packages Projects Releases Wiki Activity
gerbvhtdocs/doxygen/scheme_8c-source.html

4497 lines
342 KiB
HTML
Raw Blame History

<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.01 Transitional//EN">
<html><head><meta http-equiv="Content-Type" content="text/html;charset=UTF-8">
<title>gerbv: src/scheme.c Source File</title>
<link href="doxygen.css" rel="stylesheet" type="text/css">
<link href="tabs.css" rel="stylesheet" type="text/css">
</head><body>
<!-- Generated by Doxygen 1.5.6 -->
<div class="navigation" id="top">
<div class="tabs">
<ul>
<li><a href="main.html"><span>Main&nbsp;Page</span></a></li>
<li><a href="modules.html"><span>Modules</span></a></li>
<li><a href="classes.html"><span>Data&nbsp;Structures</span></a></li>
<li class="current"><a href="files.html"><span>Files</span></a></li>
<li><a href="dirs.html"><span>Directories</span></a></li>
<li><a href="examples.html"><span>Examples</span></a></li>
</ul>
</div>
<div class="navpath"><a class="el" href="dir_0fba06f62092f0c8d9ff47b96507f331.html">src</a>
</div>
</div>
<div class="contents">
<h1>scheme.c</h1><a href="scheme_8c.html">Go to the documentation of this file.</a><div class="fragment"><pre class="fragment"><a name="l00001"></a>00001 <span class="comment">/* T I N Y S C H E M E 1 . 3 5</span>
<a name="l00002"></a>00002 <span class="comment"> * Dimitrios Souflis (dsouflis@acm.org)</span>
<a name="l00003"></a>00003 <span class="comment"> * Based on MiniScheme (original credits follow)</span>
<a name="l00004"></a>00004 <span class="comment"> * (MINISCM) coded by Atsushi Moriwaki (11/5/1989)</span>
<a name="l00005"></a>00005 <span class="comment"> * (MINISCM) E-MAIL : moriwaki@kurims.kurims.kyoto-u.ac.jp</span>
<a name="l00006"></a>00006 <span class="comment"> * (MINISCM) This version has been modified by R.C. Secrist.</span>
<a name="l00007"></a>00007 <span class="comment"> * (MINISCM)</span>
<a name="l00008"></a>00008 <span class="comment"> * (MINISCM) Mini-Scheme is now maintained by Akira KIDA.</span>
<a name="l00009"></a>00009 <span class="comment"> * (MINISCM)</span>
<a name="l00010"></a>00010 <span class="comment"> * (MINISCM) This is a revised and modified version by Akira KIDA.</span>
<a name="l00011"></a>00011 <span class="comment"> * (MINISCM) current version is 0.85k4 (15 May 1994)</span>
<a name="l00012"></a>00012 <span class="comment"> *</span>
<a name="l00013"></a>00013 <span class="comment"> */</span>
<a name="l00014"></a>00014
<a name="l00020"></a>00020 <span class="preprocessor">#ifdef HAVE_CONFIG_H</span>
<a name="l00021"></a>00021 <span class="preprocessor"></span><span class="preprocessor">#include &lt;config.h&gt;</span>
<a name="l00022"></a>00022 <span class="preprocessor">#endif</span>
<a name="l00023"></a>00023 <span class="preprocessor"></span>
<a name="l00024"></a>00024 <span class="preprocessor">#define _SCHEME_SOURCE</span>
<a name="l00025"></a>00025 <span class="preprocessor"></span><span class="preprocessor">#include "<a class="code" href="scheme-private_8h.html" title="Private data for the TinyScheme compiler.">scheme-private.h</a>"</span>
<a name="l00026"></a>00026 <span class="preprocessor">#ifndef WIN32</span>
<a name="l00027"></a>00027 <span class="preprocessor"></span><span class="preprocessor"># include &lt;unistd.h&gt;</span>
<a name="l00028"></a>00028 <span class="preprocessor">#endif</span>
<a name="l00029"></a>00029 <span class="preprocessor"></span><span class="preprocessor">#if USE_DL</span>
<a name="l00030"></a>00030 <span class="preprocessor"></span><span class="preprocessor"># include "<a class="code" href="dynload_8h.html" title="Header info for the dynamic loader functions for TinyScheme.">dynload.h</a>"</span>
<a name="l00031"></a>00031 <span class="preprocessor">#endif</span>
<a name="l00032"></a>00032 <span class="preprocessor"></span><span class="preprocessor">#if USE_MATH</span>
<a name="l00033"></a>00033 <span class="preprocessor"></span><span class="preprocessor"># include &lt;math.h&gt;</span>
<a name="l00034"></a>00034 <span class="preprocessor">#endif</span>
<a name="l00035"></a>00035 <span class="preprocessor"></span><span class="preprocessor">#include &lt;limits.h&gt;</span>
<a name="l00036"></a>00036 <span class="preprocessor">#include &lt;float.h&gt;</span>
<a name="l00037"></a>00037 <span class="preprocessor">#include &lt;ctype.h&gt;</span>
<a name="l00038"></a>00038 <span class="preprocessor">#ifdef HAVE_UNISTD_H</span>
<a name="l00039"></a>00039 <span class="preprocessor"></span><span class="preprocessor">#include &lt;unistd.h&gt;</span> <span class="comment">/* access() on Linux */</span>
<a name="l00040"></a>00040 <span class="preprocessor">#endif</span>
<a name="l00041"></a>00041 <span class="preprocessor"></span>
<a name="l00042"></a>00042 <span class="preprocessor">#if USE_STRCASECMP</span>
<a name="l00043"></a>00043 <span class="preprocessor"></span><span class="preprocessor">#include &lt;strings.h&gt;</span>
<a name="l00044"></a>00044 <span class="preprocessor">#define stricmp strcasecmp</span>
<a name="l00045"></a>00045 <span class="preprocessor"></span><span class="preprocessor">#endif</span>
<a name="l00046"></a>00046 <span class="preprocessor"></span>
<a name="l00047"></a>00047 <span class="comment">/* Used for documentation purposes, to signal functions in 'interface' */</span>
<a name="l00048"></a>00048 <span class="preprocessor">#define INTERFACE</span>
<a name="l00049"></a>00049 <span class="preprocessor"></span>
<a name="l00050"></a>00050 <span class="preprocessor">#define TOK_EOF (-1)</span>
<a name="l00051"></a>00051 <span class="preprocessor"></span><span class="preprocessor">#define TOK_LPAREN 0</span>
<a name="l00052"></a>00052 <span class="preprocessor"></span><span class="preprocessor">#define TOK_RPAREN 1</span>
<a name="l00053"></a>00053 <span class="preprocessor"></span><span class="preprocessor">#define TOK_DOT 2</span>
<a name="l00054"></a>00054 <span class="preprocessor"></span><span class="preprocessor">#define TOK_ATOM 3</span>
<a name="l00055"></a>00055 <span class="preprocessor"></span><span class="preprocessor">#define TOK_QUOTE 4</span>
<a name="l00056"></a>00056 <span class="preprocessor"></span><span class="preprocessor">#define TOK_COMMENT 5</span>
<a name="l00057"></a>00057 <span class="preprocessor"></span><span class="preprocessor">#define TOK_DQUOTE 6</span>
<a name="l00058"></a>00058 <span class="preprocessor"></span><span class="preprocessor">#define TOK_BQUOTE 7</span>
<a name="l00059"></a>00059 <span class="preprocessor"></span><span class="preprocessor">#define TOK_COMMA 8</span>
<a name="l00060"></a>00060 <span class="preprocessor"></span><span class="preprocessor">#define TOK_ATMARK 9</span>
<a name="l00061"></a>00061 <span class="preprocessor"></span><span class="preprocessor">#define TOK_SHARP 10</span>
<a name="l00062"></a>00062 <span class="preprocessor"></span><span class="preprocessor">#define TOK_SHARP_CONST 11</span>
<a name="l00063"></a>00063 <span class="preprocessor"></span><span class="preprocessor">#define TOK_VEC 12</span>
<a name="l00064"></a>00064 <span class="preprocessor"></span>
<a name="l00065"></a>00065 <span class="preprocessor"># define BACKQUOTE '`'</span>
<a name="l00066"></a>00066 <span class="preprocessor"></span>
<a name="l00067"></a>00067 <span class="comment">/*</span>
<a name="l00068"></a>00068 <span class="comment"> * Basic memory allocation units</span>
<a name="l00069"></a>00069 <span class="comment"> */</span>
<a name="l00070"></a>00070
<a name="l00071"></a>00071 <span class="preprocessor">#define banner "TinyScheme 1.35"</span>
<a name="l00072"></a>00072 <span class="preprocessor"></span>
<a name="l00073"></a>00073 <span class="preprocessor">#ifdef HAVE_STRING_H</span>
<a name="l00074"></a>00074 <span class="preprocessor"></span><span class="preprocessor">#include &lt;string.h&gt;</span>
<a name="l00075"></a>00075 <span class="preprocessor">#endif</span>
<a name="l00076"></a>00076 <span class="preprocessor"></span><span class="preprocessor">#include &lt;stdlib.h&gt;</span>
<a name="l00077"></a>00077 <span class="preprocessor">#ifndef macintosh</span>
<a name="l00078"></a>00078 <span class="preprocessor"></span><span class="preprocessor">#ifdef HAVE_MALLOC_H</span>
<a name="l00079"></a>00079 <span class="preprocessor"></span><span class="preprocessor"># include &lt;malloc.h&gt;</span>
<a name="l00080"></a>00080 <span class="preprocessor">#endif</span>
<a name="l00081"></a>00081 <span class="preprocessor"></span><span class="preprocessor">#else</span>
<a name="l00082"></a>00082 <span class="preprocessor"></span><span class="keyword">static</span> <span class="keywordtype">int</span> stricmp(<span class="keyword">const</span> <span class="keywordtype">char</span> *s1, <span class="keyword">const</span> <span class="keywordtype">char</span> *s2)
<a name="l00083"></a>00083 {
<a name="l00084"></a>00084 <span class="keywordtype">unsigned</span> <span class="keywordtype">char</span> c1, c2;
<a name="l00085"></a>00085 <span class="keywordflow">do</span> {
<a name="l00086"></a>00086 c1 = tolower(*s1);
<a name="l00087"></a>00087 c2 = tolower(*s2);
<a name="l00088"></a>00088 <span class="keywordflow">if</span> (c1 &lt; c2)
<a name="l00089"></a>00089 <span class="keywordflow">return</span> -1;
<a name="l00090"></a>00090 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (c1 &gt; c2)
<a name="l00091"></a>00091 <span class="keywordflow">return</span> 1;
<a name="l00092"></a>00092 s1++, s2++;
<a name="l00093"></a>00093 } <span class="keywordflow">while</span> (c1 != 0);
<a name="l00094"></a>00094 <span class="keywordflow">return</span> 0;
<a name="l00095"></a>00095 }
<a name="l00096"></a>00096 <span class="preprocessor">#endif </span><span class="comment">/* macintosh */</span>
<a name="l00097"></a>00097
<a name="l00098"></a>00098 <span class="preprocessor">#ifndef HAVE_STRLWR</span>
<a name="l00099"></a>00099 <span class="preprocessor"></span><span class="keyword">static</span> <span class="keyword">const</span> <span class="keywordtype">char</span> *strlwr(<span class="keywordtype">char</span> *s) {
<a name="l00100"></a>00100 <span class="keyword">const</span> <span class="keywordtype">char</span> *p=s;
<a name="l00101"></a>00101 <span class="keywordflow">while</span>(*s) {
<a name="l00102"></a>00102 *s=tolower((<span class="keywordtype">int</span>) *s);
<a name="l00103"></a>00103 s++;
<a name="l00104"></a>00104 }
<a name="l00105"></a>00105 <span class="keywordflow">return</span> p;
<a name="l00106"></a>00106 }
<a name="l00107"></a>00107 <span class="preprocessor">#endif</span>
<a name="l00108"></a>00108 <span class="preprocessor"></span>
<a name="l00109"></a>00109 <span class="preprocessor">#ifndef prompt</span>
<a name="l00110"></a>00110 <span class="preprocessor"></span><span class="preprocessor"># define prompt "&gt; "</span>
<a name="l00111"></a>00111 <span class="preprocessor"></span><span class="preprocessor">#endif</span>
<a name="l00112"></a>00112 <span class="preprocessor"></span>
<a name="l00113"></a>00113 <span class="preprocessor">#ifndef InitFile</span>
<a name="l00114"></a>00114 <span class="preprocessor"></span><span class="preprocessor"># define InitFile "init.scm"</span>
<a name="l00115"></a>00115 <span class="preprocessor"></span><span class="preprocessor">#endif</span>
<a name="l00116"></a>00116 <span class="preprocessor"></span>
<a name="l00117"></a>00117 <span class="preprocessor">#ifndef FIRST_CELLSEGS</span>
<a name="l00118"></a>00118 <span class="preprocessor"></span><span class="preprocessor"># define FIRST_CELLSEGS 3</span>
<a name="l00119"></a>00119 <span class="preprocessor"></span><span class="preprocessor">#endif</span>
<a name="l00120"></a>00120 <span class="preprocessor"></span>
<a name="l00121"></a>00121 <span class="keyword">enum</span> scheme_types {
<a name="l00122"></a>00122 T_STRING=1,
<a name="l00123"></a>00123 T_NUMBER=2,
<a name="l00124"></a>00124 T_SYMBOL=3,
<a name="l00125"></a>00125 T_PROC=4,
<a name="l00126"></a>00126 T_PAIR=5,
<a name="l00127"></a>00127 T_CLOSURE=6,
<a name="l00128"></a>00128 T_CONTINUATION=7,
<a name="l00129"></a>00129 T_FOREIGN=8,
<a name="l00130"></a>00130 T_CHARACTER=9,
<a name="l00131"></a>00131 T_PORT=10,
<a name="l00132"></a>00132 T_VECTOR=11,
<a name="l00133"></a>00133 T_MACRO=12,
<a name="l00134"></a>00134 T_PROMISE=13,
<a name="l00135"></a>00135 T_ENVIRONMENT=14,
<a name="l00136"></a>00136 T_LAST_SYSTEM_TYPE=14
<a name="l00137"></a>00137 };
<a name="l00138"></a>00138
<a name="l00139"></a>00139 <span class="comment">/* ADJ is enough slack to align cells in a TYPE_BITS-bit boundary */</span>
<a name="l00140"></a>00140 <span class="preprocessor">#define ADJ 32</span>
<a name="l00141"></a>00141 <span class="preprocessor"></span><span class="preprocessor">#define TYPE_BITS 5</span>
<a name="l00142"></a>00142 <span class="preprocessor"></span><span class="preprocessor">#define T_MASKTYPE 31 </span><span class="comment">/* 0000000000011111 */</span>
<a name="l00143"></a>00143 <span class="preprocessor">#define T_SYNTAX 4096 </span><span class="comment">/* 0001000000000000 */</span>
<a name="l00144"></a>00144 <span class="preprocessor">#define T_IMMUTABLE 8192 </span><span class="comment">/* 0010000000000000 */</span>
<a name="l00145"></a>00145 <span class="preprocessor">#define T_ATOM 16384 </span><span class="comment">/* 0100000000000000 */</span> <span class="comment">/* only for gc */</span>
<a name="l00146"></a>00146 <span class="preprocessor">#define CLRATOM 49151 </span><span class="comment">/* 1011111111111111 */</span> <span class="comment">/* only for gc */</span>
<a name="l00147"></a>00147 <span class="preprocessor">#define MARK 32768 </span><span class="comment">/* 1000000000000000 */</span>
<a name="l00148"></a>00148 <span class="preprocessor">#define UNMARK 32767 </span><span class="comment">/* 0111111111111111 */</span>
<a name="l00149"></a>00149
<a name="l00150"></a>00150
<a name="l00151"></a>00151 <span class="keyword">static</span> num num_add(num a, num b);
<a name="l00152"></a>00152 <span class="keyword">static</span> num num_mul(num a, num b);
<a name="l00153"></a>00153 <span class="keyword">static</span> num num_div(num a, num b);
<a name="l00154"></a>00154 <span class="keyword">static</span> num num_intdiv(num a, num b);
<a name="l00155"></a>00155 <span class="keyword">static</span> num num_sub(num a, num b);
<a name="l00156"></a>00156 <span class="keyword">static</span> num num_rem(num a, num b);
<a name="l00157"></a>00157 <span class="keyword">static</span> num num_mod(num a, num b);
<a name="l00158"></a>00158 <span class="keyword">static</span> <span class="keywordtype">int</span> num_eq(num a, num b);
<a name="l00159"></a>00159 <span class="keyword">static</span> <span class="keywordtype">int</span> num_gt(num a, num b);
<a name="l00160"></a>00160 <span class="keyword">static</span> <span class="keywordtype">int</span> num_ge(num a, num b);
<a name="l00161"></a>00161 <span class="keyword">static</span> <span class="keywordtype">int</span> num_lt(num a, num b);
<a name="l00162"></a>00162 <span class="keyword">static</span> <span class="keywordtype">int</span> num_le(num a, num b);
<a name="l00163"></a>00163
<a name="l00164"></a>00164 <span class="preprocessor">#if USE_MATH</span>
<a name="l00165"></a>00165 <span class="preprocessor"></span><span class="keyword">static</span> <span class="keywordtype">double</span> round_per_R5RS(<span class="keywordtype">double</span> x);
<a name="l00166"></a>00166 <span class="preprocessor">#endif</span>
<a name="l00167"></a>00167 <span class="preprocessor"></span><span class="keyword">static</span> <span class="keywordtype">int</span> is_zero_double(<span class="keywordtype">double</span> x);
<a name="l00168"></a>00168
<a name="l00169"></a>00169 <span class="keyword">static</span> num num_zero;
<a name="l00170"></a>00170 <span class="keyword">static</span> num num_one;
<a name="l00171"></a>00171
<a name="l00172"></a>00172 <span class="comment">/* macros for cell operations */</span>
<a name="l00173"></a>00173 <span class="preprocessor">#define typeflag(p) ((p)-&gt;_flag)</span>
<a name="l00174"></a>00174 <span class="preprocessor"></span><span class="preprocessor">#define type(p) (typeflag(p)&amp;T_MASKTYPE)</span>
<a name="l00175"></a>00175 <span class="preprocessor"></span>
<a name="l00176"></a>00176 INTERFACE INLINE <span class="keywordtype">int</span> is_string(pointer p) { <span class="keywordflow">return</span> (type(p)==T_STRING); }
<a name="l00177"></a>00177 <span class="preprocessor">#define strvalue(p) ((p)-&gt;_object._string._svalue)</span>
<a name="l00178"></a>00178 <span class="preprocessor"></span><span class="preprocessor">#define strlength(p) ((p)-&gt;_object._string._length)</span>
<a name="l00179"></a>00179 <span class="preprocessor"></span>
<a name="l00180"></a>00180 INTERFACE INLINE <span class="keywordtype">int</span> is_vector(pointer p) { <span class="keywordflow">return</span> (type(p)==T_VECTOR); }
<a name="l00181"></a>00181 INTERFACE <span class="keyword">static</span> <span class="keywordtype">void</span> fill_vector(pointer vec, pointer obj);
<a name="l00182"></a>00182 INTERFACE <span class="keyword">static</span> pointer vector_elem(pointer vec, <span class="keywordtype">int</span> ielem);
<a name="l00183"></a>00183 INTERFACE <span class="keyword">static</span> pointer set_vector_elem(pointer vec, <span class="keywordtype">int</span> ielem, pointer a);
<a name="l00184"></a>00184 INTERFACE INLINE <span class="keywordtype">int</span> is_number(pointer p) { <span class="keywordflow">return</span> (type(p)==T_NUMBER); }
<a name="l00185"></a>00185 INTERFACE INLINE <span class="keywordtype">int</span> is_integer(pointer p) {
<a name="l00186"></a>00186 <span class="keywordflow">return</span> ((p)-&gt;_object._number.is_fixnum);
<a name="l00187"></a>00187 }
<a name="l00188"></a>00188 INTERFACE INLINE <span class="keywordtype">int</span> is_real(pointer p) {
<a name="l00189"></a>00189 <span class="keywordflow">return</span> (!(p)-&gt;_object._number.is_fixnum);
<a name="l00190"></a>00190 }
<a name="l00191"></a>00191
<a name="l00192"></a>00192 INTERFACE INLINE <span class="keywordtype">int</span> is_character(pointer p) { <span class="keywordflow">return</span> (type(p)==T_CHARACTER); }
<a name="l00193"></a>00193 INTERFACE INLINE <span class="keywordtype">char</span> *string_value(pointer p) { <span class="keywordflow">return</span> strvalue(p); }
<a name="l00194"></a>00194 INLINE num nvalue(pointer p) { <span class="keywordflow">return</span> ((p)-&gt;_object._number); }
<a name="l00195"></a>00195 INTERFACE <span class="keywordtype">long</span> ivalue(pointer p) { <span class="keywordflow">return</span> (is_integer(p)?(p)-&gt;_object._number.value.ivalue:(<span class="keywordtype">long</span>)(p)-&gt;_object._number.value.rvalue); }
<a name="l00196"></a>00196 INTERFACE <span class="keywordtype">double</span> rvalue(pointer p) { <span class="keywordflow">return</span> (!is_integer(p)?(p)-&gt;_object._number.value.rvalue:(<span class="keywordtype">double</span>)(p)-&gt;_object._number.value.ivalue); }
<a name="l00197"></a>00197 <span class="preprocessor">#define ivalue_unchecked(p) ((p)-&gt;_object._number.value.ivalue)</span>
<a name="l00198"></a>00198 <span class="preprocessor"></span><span class="preprocessor">#define rvalue_unchecked(p) ((p)-&gt;_object._number.value.rvalue)</span>
<a name="l00199"></a>00199 <span class="preprocessor"></span><span class="preprocessor">#define set_integer(p) (p)-&gt;_object._number.is_fixnum=1;</span>
<a name="l00200"></a>00200 <span class="preprocessor"></span><span class="preprocessor">#define set_real(p) (p)-&gt;_object._number.is_fixnum=0;</span>
<a name="l00201"></a>00201 <span class="preprocessor"></span>INTERFACE <span class="keywordtype">long</span> charvalue(pointer p) { <span class="keywordflow">return</span> ivalue_unchecked(p); }
<a name="l00202"></a>00202
<a name="l00203"></a>00203 INTERFACE INLINE <span class="keywordtype">int</span> is_port(pointer p) { <span class="keywordflow">return</span> (type(p)==T_PORT); }
<a name="l00204"></a>00204 <span class="preprocessor">#define is_inport(p) (type(p)==T_PORT &amp;&amp; p-&gt;_object._port-&gt;kind&amp;port_input)</span>
<a name="l00205"></a>00205 <span class="preprocessor"></span><span class="preprocessor">#define is_outport(p) (type(p)==T_PORT &amp;&amp; p-&gt;_object._port-&gt;kind&amp;port_output)</span>
<a name="l00206"></a>00206 <span class="preprocessor"></span>
<a name="l00207"></a>00207 INTERFACE INLINE <span class="keywordtype">int</span> is_pair(pointer p) { <span class="keywordflow">return</span> (type(p)==T_PAIR); }
<a name="l00208"></a>00208 <span class="preprocessor">#define car(p) ((p)-&gt;_object._cons._car)</span>
<a name="l00209"></a>00209 <span class="preprocessor"></span><span class="preprocessor">#define cdr(p) ((p)-&gt;_object._cons._cdr)</span>
<a name="l00210"></a>00210 <span class="preprocessor"></span>INTERFACE pointer pair_car(pointer p) { <span class="keywordflow">return</span> car(p); }
<a name="l00211"></a>00211 INTERFACE pointer pair_cdr(pointer p) { <span class="keywordflow">return</span> cdr(p); }
<a name="l00212"></a>00212 INTERFACE pointer set_car(pointer p, pointer q) { <span class="keywordflow">return</span> car(p)=q; }
<a name="l00213"></a>00213 INTERFACE pointer set_cdr(pointer p, pointer q) { <span class="keywordflow">return</span> cdr(p)=q; }
<a name="l00214"></a>00214
<a name="l00215"></a>00215 INTERFACE INLINE <span class="keywordtype">int</span> is_symbol(pointer p) { <span class="keywordflow">return</span> (type(p)==T_SYMBOL); }
<a name="l00216"></a>00216 INTERFACE INLINE <span class="keywordtype">char</span> *symname(pointer p) { <span class="keywordflow">return</span> strvalue(car(p)); }
<a name="l00217"></a>00217 <span class="preprocessor">#if USE_PLIST</span>
<a name="l00218"></a>00218 <span class="preprocessor"></span>SCHEME_EXPORT INLINE <span class="keywordtype">int</span> hasprop(pointer p) { <span class="keywordflow">return</span> (typeflag(p)&amp;T_SYMBOL); }
<a name="l00219"></a>00219 <span class="preprocessor">#define symprop(p) cdr(p)</span>
<a name="l00220"></a>00220 <span class="preprocessor"></span><span class="preprocessor">#endif</span>
<a name="l00221"></a>00221 <span class="preprocessor"></span>
<a name="l00222"></a>00222 INTERFACE INLINE <span class="keywordtype">int</span> is_syntax(pointer p) { <span class="keywordflow">return</span> (typeflag(p)&amp;T_SYNTAX); }
<a name="l00223"></a>00223 INTERFACE INLINE <span class="keywordtype">int</span> is_proc(pointer p) { <span class="keywordflow">return</span> (type(p)==T_PROC); }
<a name="l00224"></a>00224 INTERFACE INLINE <span class="keywordtype">int</span> is_foreign(pointer p) { <span class="keywordflow">return</span> (type(p)==T_FOREIGN); }
<a name="l00225"></a>00225 INTERFACE INLINE <span class="keywordtype">char</span> *syntaxname(pointer p) { <span class="keywordflow">return</span> strvalue(car(p)); }
<a name="l00226"></a>00226 <span class="preprocessor">#define procnum(p) ivalue(p)</span>
<a name="l00227"></a>00227 <span class="preprocessor"></span><span class="keyword">static</span> <span class="keyword">const</span> <span class="keywordtype">char</span> *procname(pointer x);
<a name="l00228"></a>00228
<a name="l00229"></a>00229 INTERFACE INLINE <span class="keywordtype">int</span> is_closure(pointer p) { <span class="keywordflow">return</span> (type(p)==T_CLOSURE); }
<a name="l00230"></a>00230 INTERFACE INLINE <span class="keywordtype">int</span> is_macro(pointer p) { <span class="keywordflow">return</span> (type(p)==T_MACRO); }
<a name="l00231"></a>00231 INTERFACE INLINE pointer closure_code(pointer p) { <span class="keywordflow">return</span> car(p); }
<a name="l00232"></a>00232 INTERFACE INLINE pointer closure_env(pointer p) { <span class="keywordflow">return</span> cdr(p); }
<a name="l00233"></a>00233
<a name="l00234"></a>00234 INTERFACE INLINE <span class="keywordtype">int</span> is_continuation(pointer p) { <span class="keywordflow">return</span> (type(p)==T_CONTINUATION); }
<a name="l00235"></a>00235 <span class="preprocessor">#define cont_dump(p) cdr(p)</span>
<a name="l00236"></a>00236 <span class="preprocessor"></span>
<a name="l00237"></a>00237 <span class="comment">/* To do: promise should be forced ONCE only */</span>
<a name="l00238"></a>00238 INTERFACE INLINE <span class="keywordtype">int</span> is_promise(pointer p) { <span class="keywordflow">return</span> (type(p)==T_PROMISE); }
<a name="l00239"></a>00239
<a name="l00240"></a>00240 INTERFACE INLINE <span class="keywordtype">int</span> is_environment(pointer p) { <span class="keywordflow">return</span> (type(p)==T_ENVIRONMENT); }
<a name="l00241"></a>00241 <span class="preprocessor">#define setenvironment(p) typeflag(p) = T_ENVIRONMENT</span>
<a name="l00242"></a>00242 <span class="preprocessor"></span>
<a name="l00243"></a>00243 <span class="preprocessor">#define is_atom(p) (typeflag(p)&amp;T_ATOM)</span>
<a name="l00244"></a>00244 <span class="preprocessor"></span><span class="preprocessor">#define setatom(p) typeflag(p) |= T_ATOM</span>
<a name="l00245"></a>00245 <span class="preprocessor"></span><span class="preprocessor">#define clratom(p) typeflag(p) &amp;= CLRATOM</span>
<a name="l00246"></a>00246 <span class="preprocessor"></span>
<a name="l00247"></a>00247 <span class="preprocessor">#define is_mark(p) (typeflag(p)&amp;MARK)</span>
<a name="l00248"></a>00248 <span class="preprocessor"></span><span class="preprocessor">#define setmark(p) typeflag(p) |= MARK</span>
<a name="l00249"></a>00249 <span class="preprocessor"></span><span class="preprocessor">#define clrmark(p) typeflag(p) &amp;= UNMARK</span>
<a name="l00250"></a>00250 <span class="preprocessor"></span>
<a name="l00251"></a>00251 INTERFACE INLINE <span class="keywordtype">int</span> is_immutable(pointer p) { <span class="keywordflow">return</span> (typeflag(p)&amp;T_IMMUTABLE); }
<a name="l00252"></a>00252 <span class="comment">/*#define setimmutable(p) typeflag(p) |= T_IMMUTABLE*/</span>
<a name="l00253"></a>00253 INTERFACE INLINE <span class="keywordtype">void</span> setimmutable(pointer p) { typeflag(p) |= T_IMMUTABLE; }
<a name="l00254"></a>00254
<a name="l00255"></a>00255 <span class="preprocessor">#define caar(p) car(car(p))</span>
<a name="l00256"></a>00256 <span class="preprocessor"></span><span class="preprocessor">#define cadr(p) car(cdr(p))</span>
<a name="l00257"></a>00257 <span class="preprocessor"></span><span class="preprocessor">#define cdar(p) cdr(car(p))</span>
<a name="l00258"></a>00258 <span class="preprocessor"></span><span class="preprocessor">#define cddr(p) cdr(cdr(p))</span>
<a name="l00259"></a>00259 <span class="preprocessor"></span><span class="preprocessor">#define cadar(p) car(cdr(car(p)))</span>
<a name="l00260"></a>00260 <span class="preprocessor"></span><span class="preprocessor">#define caddr(p) car(cdr(cdr(p)))</span>
<a name="l00261"></a>00261 <span class="preprocessor"></span><span class="preprocessor">#define cadaar(p) car(cdr(car(car(p))))</span>
<a name="l00262"></a>00262 <span class="preprocessor"></span><span class="preprocessor">#define cadddr(p) car(cdr(cdr(cdr(p))))</span>
<a name="l00263"></a>00263 <span class="preprocessor"></span><span class="preprocessor">#define cddddr(p) cdr(cdr(cdr(cdr(p))))</span>
<a name="l00264"></a>00264 <span class="preprocessor"></span>
<a name="l00265"></a>00265 <span class="preprocessor">#if USE_CHAR_CLASSIFIERS</span>
<a name="l00266"></a>00266 <span class="preprocessor"></span><span class="keyword">static</span> INLINE <span class="keywordtype">int</span> Cisalpha(<span class="keywordtype">int</span> c) { <span class="keywordflow">return</span> isascii(c) &amp;&amp; isalpha(c); }
<a name="l00267"></a>00267 <span class="keyword">static</span> INLINE <span class="keywordtype">int</span> Cisdigit(<span class="keywordtype">int</span> c) { <span class="keywordflow">return</span> isascii(c) &amp;&amp; isdigit(c); }
<a name="l00268"></a>00268 <span class="keyword">static</span> INLINE <span class="keywordtype">int</span> Cisspace(<span class="keywordtype">int</span> c) { <span class="keywordflow">return</span> isascii(c) &amp;&amp; isspace(c); }
<a name="l00269"></a>00269 <span class="keyword">static</span> INLINE <span class="keywordtype">int</span> Cisupper(<span class="keywordtype">int</span> c) { <span class="keywordflow">return</span> isascii(c) &amp;&amp; isupper(c); }
<a name="l00270"></a>00270 <span class="keyword">static</span> INLINE <span class="keywordtype">int</span> Cislower(<span class="keywordtype">int</span> c) { <span class="keywordflow">return</span> isascii(c) &amp;&amp; islower(c); }
<a name="l00271"></a>00271 <span class="preprocessor">#endif</span>
<a name="l00272"></a>00272 <span class="preprocessor"></span>
<a name="l00273"></a>00273 <span class="preprocessor">#if USE_ASCII_NAMES</span>
<a name="l00274"></a>00274 <span class="preprocessor"></span><span class="keyword">static</span> <span class="keyword">const</span> <span class="keywordtype">char</span> *charnames[32]={
<a name="l00275"></a>00275 <span class="stringliteral">"nul"</span>,
<a name="l00276"></a>00276 <span class="stringliteral">"soh"</span>,
<a name="l00277"></a>00277 <span class="stringliteral">"stx"</span>,
<a name="l00278"></a>00278 <span class="stringliteral">"etx"</span>,
<a name="l00279"></a>00279 <span class="stringliteral">"eot"</span>,
<a name="l00280"></a>00280 <span class="stringliteral">"enq"</span>,
<a name="l00281"></a>00281 <span class="stringliteral">"ack"</span>,
<a name="l00282"></a>00282 <span class="stringliteral">"bel"</span>,
<a name="l00283"></a>00283 <span class="stringliteral">"bs"</span>,
<a name="l00284"></a>00284 <span class="stringliteral">"ht"</span>,
<a name="l00285"></a>00285 <span class="stringliteral">"lf"</span>,
<a name="l00286"></a>00286 <span class="stringliteral">"vt"</span>,
<a name="l00287"></a>00287 <span class="stringliteral">"ff"</span>,
<a name="l00288"></a>00288 <span class="stringliteral">"cr"</span>,
<a name="l00289"></a>00289 <span class="stringliteral">"so"</span>,
<a name="l00290"></a>00290 <span class="stringliteral">"si"</span>,
<a name="l00291"></a>00291 <span class="stringliteral">"dle"</span>,
<a name="l00292"></a>00292 <span class="stringliteral">"dc1"</span>,
<a name="l00293"></a>00293 <span class="stringliteral">"dc2"</span>,
<a name="l00294"></a>00294 <span class="stringliteral">"dc3"</span>,
<a name="l00295"></a>00295 <span class="stringliteral">"dc4"</span>,
<a name="l00296"></a>00296 <span class="stringliteral">"nak"</span>,
<a name="l00297"></a>00297 <span class="stringliteral">"syn"</span>,
<a name="l00298"></a>00298 <span class="stringliteral">"etb"</span>,
<a name="l00299"></a>00299 <span class="stringliteral">"can"</span>,
<a name="l00300"></a>00300 <span class="stringliteral">"em"</span>,
<a name="l00301"></a>00301 <span class="stringliteral">"sub"</span>,
<a name="l00302"></a>00302 <span class="stringliteral">"esc"</span>,
<a name="l00303"></a>00303 <span class="stringliteral">"fs"</span>,
<a name="l00304"></a>00304 <span class="stringliteral">"gs"</span>,
<a name="l00305"></a>00305 <span class="stringliteral">"rs"</span>,
<a name="l00306"></a>00306 <span class="stringliteral">"us"</span>
<a name="l00307"></a>00307 };
<a name="l00308"></a>00308
<a name="l00309"></a>00309 <span class="keyword">static</span> <span class="keywordtype">int</span> is_ascii_name(<span class="keyword">const</span> <span class="keywordtype">char</span> *name, <span class="keywordtype">int</span> *pc) {
<a name="l00310"></a>00310 <span class="keywordtype">int</span> i;
<a name="l00311"></a>00311 <span class="keywordflow">for</span>(i=0; i&lt;32; i++) {
<a name="l00312"></a>00312 <span class="keywordflow">if</span>(stricmp(name,charnames[i])==0) {
<a name="l00313"></a>00313 *pc=i;
<a name="l00314"></a>00314 <span class="keywordflow">return</span> 1;
<a name="l00315"></a>00315 }
<a name="l00316"></a>00316 }
<a name="l00317"></a>00317 <span class="keywordflow">if</span>(stricmp(name,<span class="stringliteral">"del"</span>)==0) {
<a name="l00318"></a>00318 *pc=127;
<a name="l00319"></a>00319 <span class="keywordflow">return</span> 1;
<a name="l00320"></a>00320 }
<a name="l00321"></a>00321 <span class="keywordflow">return</span> 0;
<a name="l00322"></a>00322 }
<a name="l00323"></a>00323
<a name="l00324"></a>00324 <span class="preprocessor">#endif</span>
<a name="l00325"></a>00325 <span class="preprocessor"></span>
<a name="l00326"></a>00326 <span class="keyword">static</span> <span class="keywordtype">int</span> file_push(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *fname);
<a name="l00327"></a>00327 <span class="keyword">static</span> <span class="keywordtype">void</span> file_pop(scheme *sc);
<a name="l00328"></a>00328 <span class="keyword">static</span> <span class="keywordtype">int</span> file_interactive(scheme *sc);
<a name="l00329"></a>00329 <span class="keyword">static</span> INLINE <span class="keywordtype">int</span> is_one_of(<span class="keywordtype">char</span> *s, <span class="keywordtype">int</span> c);
<a name="l00330"></a>00330 <span class="keyword">static</span> <span class="keywordtype">int</span> alloc_cellseg(scheme *sc, <span class="keywordtype">int</span> n);
<a name="l00331"></a>00331 <span class="keyword">static</span> <span class="keywordtype">long</span> binary_decode(<span class="keyword">const</span> <span class="keywordtype">char</span> *s);
<a name="l00332"></a>00332 <span class="keyword">static</span> INLINE pointer get_cell(scheme *sc, pointer a, pointer b);
<a name="l00333"></a>00333 <span class="keyword">static</span> pointer _get_cell(scheme *sc, pointer a, pointer b);
<a name="l00334"></a>00334 <span class="keyword">static</span> pointer get_consecutive_cells(scheme *sc, <span class="keywordtype">int</span> n);
<a name="l00335"></a>00335 <span class="keyword">static</span> pointer find_consecutive_cells(scheme *sc, <span class="keywordtype">int</span> n);
<a name="l00336"></a>00336 <span class="keyword">static</span> <span class="keywordtype">void</span> finalize_cell(scheme *sc, pointer a);
<a name="l00337"></a>00337 <span class="keyword">static</span> <span class="keywordtype">int</span> count_consecutive_cells(pointer x, <span class="keywordtype">int</span> needed);
<a name="l00338"></a>00338 <span class="keyword">static</span> pointer find_slot_in_env(scheme *sc, pointer env, pointer sym, <span class="keywordtype">int</span> all);
<a name="l00339"></a>00339 <span class="keyword">static</span> pointer mk_number(scheme *sc, num n);
<a name="l00340"></a>00340 <span class="keyword">static</span> pointer mk_empty_string(scheme *sc, <span class="keywordtype">int</span> len, <span class="keywordtype">char</span> fill);
<a name="l00341"></a>00341 <span class="keyword">static</span> <span class="keywordtype">char</span> *store_string(scheme *sc, <span class="keywordtype">int</span> len, <span class="keyword">const</span> <span class="keywordtype">char</span> *str, <span class="keywordtype">char</span> fill);
<a name="l00342"></a>00342 <span class="keyword">static</span> pointer mk_vector(scheme *sc, <span class="keywordtype">int</span> len);
<a name="l00343"></a>00343 <span class="keyword">static</span> pointer mk_atom(scheme *sc, <span class="keywordtype">char</span> *q);
<a name="l00344"></a>00344 <span class="keyword">static</span> pointer mk_sharp_const(scheme *sc, <span class="keywordtype">char</span> *name);
<a name="l00345"></a>00345 <span class="keyword">static</span> pointer mk_port(scheme *sc, port *p);
<a name="l00346"></a>00346 <span class="keyword">static</span> pointer port_from_filename(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *fn, <span class="keywordtype">int</span> prop);
<a name="l00347"></a>00347 <span class="keyword">static</span> pointer port_from_file(scheme *sc, FILE *, <span class="keywordtype">int</span> prop);
<a name="l00348"></a>00348 <span class="keyword">static</span> pointer port_from_string(scheme *sc, <span class="keywordtype">char</span> *start, <span class="keywordtype">char</span> *past_the_end, <span class="keywordtype">int</span> prop);
<a name="l00349"></a>00349 <span class="keyword">static</span> port *port_rep_from_filename(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *fn, <span class="keywordtype">int</span> prop);
<a name="l00350"></a>00350 <span class="keyword">static</span> port *port_rep_from_file(scheme *sc, FILE *, <span class="keywordtype">int</span> prop);
<a name="l00351"></a>00351 <span class="keyword">static</span> port *port_rep_from_string(scheme *sc, <span class="keywordtype">char</span> *start, <span class="keywordtype">char</span> *past_the_end, <span class="keywordtype">int</span> prop);
<a name="l00352"></a>00352 <span class="keyword">static</span> <span class="keywordtype">void</span> port_close(scheme *sc, pointer p, <span class="keywordtype">int</span> flag);
<a name="l00353"></a>00353 <span class="keyword">static</span> <span class="keywordtype">void</span> mark(pointer a);
<a name="l00354"></a>00354 <span class="keyword">static</span> <span class="keywordtype">void</span> gc(scheme *sc, pointer a, pointer b);
<a name="l00355"></a>00355 <span class="keyword">static</span> <span class="keywordtype">int</span> basic_inchar(port *pt);
<a name="l00356"></a>00356 <span class="keyword">static</span> <span class="keywordtype">int</span> inchar(scheme *sc);
<a name="l00357"></a>00357 <span class="keyword">static</span> <span class="keywordtype">void</span> backchar(scheme *sc, <span class="keywordtype">int</span> c);
<a name="l00358"></a>00358 <span class="keyword">static</span> <span class="keywordtype">char</span> *readstr_upto(scheme *sc, <span class="keywordtype">char</span> *delim);
<a name="l00359"></a>00359 <span class="keyword">static</span> pointer readstrexp(scheme *sc);
<a name="l00360"></a>00360 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> skipspace(scheme *sc);
<a name="l00361"></a>00361 <span class="keyword">static</span> <span class="keywordtype">int</span> token(scheme *sc);
<a name="l00362"></a>00362 <span class="keyword">static</span> <span class="keywordtype">void</span> printslashstring(scheme *sc, <span class="keywordtype">char</span> *s, <span class="keywordtype">int</span> len);
<a name="l00363"></a>00363 <span class="keyword">static</span> <span class="keywordtype">void</span> atom2str(scheme *sc, pointer l, <span class="keywordtype">int</span> f, <span class="keywordtype">char</span> **pp, <span class="keywordtype">int</span> *plen);
<a name="l00364"></a>00364 <span class="keyword">static</span> <span class="keywordtype">void</span> printatom(scheme *sc, pointer l, <span class="keywordtype">int</span> f);
<a name="l00365"></a>00365 <span class="keyword">static</span> pointer mk_proc(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op);
<a name="l00366"></a>00366 <span class="keyword">static</span> pointer mk_closure(scheme *sc, pointer c, pointer e);
<a name="l00367"></a>00367 <span class="keyword">static</span> pointer mk_continuation(scheme *sc, pointer d);
<a name="l00368"></a>00368 <span class="keyword">static</span> pointer reverse(scheme *sc, pointer a);
<a name="l00369"></a>00369 <span class="keyword">static</span> pointer reverse_in_place(scheme *sc, pointer term, pointer list);
<a name="l00370"></a>00370 <span class="keyword">static</span> pointer append(scheme *sc, pointer a, pointer b);
<a name="l00371"></a>00371 <span class="keyword">static</span> <span class="keywordtype">int</span> list_length(scheme *sc, pointer a);
<a name="l00372"></a>00372 <span class="keyword">static</span> <span class="keywordtype">int</span> eqv(pointer a, pointer b);
<a name="l00373"></a>00373 <span class="keyword">static</span> <span class="keywordtype">void</span> dump_stack_mark(scheme *);
<a name="l00374"></a>00374 <span class="keyword">static</span> pointer opexe_0(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op);
<a name="l00375"></a>00375 <span class="keyword">static</span> pointer opexe_1(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op);
<a name="l00376"></a>00376 <span class="keyword">static</span> pointer opexe_2(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op);
<a name="l00377"></a>00377 <span class="keyword">static</span> pointer opexe_3(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op);
<a name="l00378"></a>00378 <span class="keyword">static</span> pointer opexe_4(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op);
<a name="l00379"></a>00379 <span class="keyword">static</span> pointer opexe_5(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op);
<a name="l00380"></a>00380 <span class="keyword">static</span> pointer opexe_6(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op);
<a name="l00381"></a>00381 <span class="keyword">static</span> <span class="keywordtype">void</span> Eval_Cycle(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op);
<a name="l00382"></a>00382 <span class="keyword">static</span> <span class="keywordtype">void</span> assign_syntax(scheme *sc, <span class="keywordtype">char</span> *name);
<a name="l00383"></a>00383 <span class="keyword">static</span> <span class="keywordtype">int</span> syntaxnum(pointer p);
<a name="l00384"></a>00384 <span class="keyword">static</span> <span class="keywordtype">void</span> assign_proc(scheme *sc, <span class="keyword">enum</span> scheme_opcodes, <span class="keywordtype">char</span> *name);
<a name="l00385"></a>00385
<a name="l00386"></a>00386 <span class="preprocessor">#define num_ivalue(n) (n.is_fixnum?(n).value.ivalue:(long)(n).value.rvalue)</span>
<a name="l00387"></a>00387 <span class="preprocessor"></span><span class="preprocessor">#define num_rvalue(n) (!n.is_fixnum?(n).value.rvalue:(double)(n).value.ivalue)</span>
<a name="l00388"></a>00388 <span class="preprocessor"></span>
<a name="l00389"></a>00389 <span class="keyword">static</span> num num_add(num a, num b) {
<a name="l00390"></a>00390 num ret;
<a name="l00391"></a>00391 ret.is_fixnum=a.is_fixnum &amp;&amp; b.is_fixnum;
<a name="l00392"></a>00392 <span class="keywordflow">if</span>(ret.is_fixnum) {
<a name="l00393"></a>00393 ret.value.ivalue= a.value.ivalue+b.value.ivalue;
<a name="l00394"></a>00394 } <span class="keywordflow">else</span> {
<a name="l00395"></a>00395 ret.value.rvalue=num_rvalue(a)+num_rvalue(b);
<a name="l00396"></a>00396 }
<a name="l00397"></a>00397 <span class="keywordflow">return</span> ret;
<a name="l00398"></a>00398 }
<a name="l00399"></a>00399
<a name="l00400"></a>00400 <span class="keyword">static</span> num num_mul(num a, num b) {
<a name="l00401"></a>00401 num ret;
<a name="l00402"></a>00402 ret.is_fixnum=a.is_fixnum &amp;&amp; b.is_fixnum;
<a name="l00403"></a>00403 <span class="keywordflow">if</span>(ret.is_fixnum) {
<a name="l00404"></a>00404 ret.value.ivalue= a.value.ivalue*b.value.ivalue;
<a name="l00405"></a>00405 } <span class="keywordflow">else</span> {
<a name="l00406"></a>00406 ret.value.rvalue=num_rvalue(a)*num_rvalue(b);
<a name="l00407"></a>00407 }
<a name="l00408"></a>00408 <span class="keywordflow">return</span> ret;
<a name="l00409"></a>00409 }
<a name="l00410"></a>00410
<a name="l00411"></a>00411 <span class="keyword">static</span> num num_div(num a, num b) {
<a name="l00412"></a>00412 num ret;
<a name="l00413"></a>00413 ret.is_fixnum=a.is_fixnum &amp;&amp; b.is_fixnum &amp;&amp; a.value.ivalue%b.value.ivalue==0;
<a name="l00414"></a>00414 <span class="keywordflow">if</span>(ret.is_fixnum) {
<a name="l00415"></a>00415 ret.value.ivalue= a.value.ivalue/b.value.ivalue;
<a name="l00416"></a>00416 } <span class="keywordflow">else</span> {
<a name="l00417"></a>00417 ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
<a name="l00418"></a>00418 }
<a name="l00419"></a>00419 <span class="keywordflow">return</span> ret;
<a name="l00420"></a>00420 }
<a name="l00421"></a>00421
<a name="l00422"></a>00422 <span class="keyword">static</span> num num_intdiv(num a, num b) {
<a name="l00423"></a>00423 num ret;
<a name="l00424"></a>00424 ret.is_fixnum=a.is_fixnum &amp;&amp; b.is_fixnum;
<a name="l00425"></a>00425 <span class="keywordflow">if</span>(ret.is_fixnum) {
<a name="l00426"></a>00426 ret.value.ivalue= a.value.ivalue/b.value.ivalue;
<a name="l00427"></a>00427 } <span class="keywordflow">else</span> {
<a name="l00428"></a>00428 ret.value.rvalue=num_rvalue(a)/num_rvalue(b);
<a name="l00429"></a>00429 }
<a name="l00430"></a>00430 <span class="keywordflow">return</span> ret;
<a name="l00431"></a>00431 }
<a name="l00432"></a>00432
<a name="l00433"></a>00433 <span class="keyword">static</span> num num_sub(num a, num b) {
<a name="l00434"></a>00434 num ret;
<a name="l00435"></a>00435 ret.is_fixnum=a.is_fixnum &amp;&amp; b.is_fixnum;
<a name="l00436"></a>00436 <span class="keywordflow">if</span>(ret.is_fixnum) {
<a name="l00437"></a>00437 ret.value.ivalue= a.value.ivalue-b.value.ivalue;
<a name="l00438"></a>00438 } <span class="keywordflow">else</span> {
<a name="l00439"></a>00439 ret.value.rvalue=num_rvalue(a)-num_rvalue(b);
<a name="l00440"></a>00440 }
<a name="l00441"></a>00441 <span class="keywordflow">return</span> ret;
<a name="l00442"></a>00442 }
<a name="l00443"></a>00443
<a name="l00444"></a>00444 <span class="keyword">static</span> num num_rem(num a, num b) {
<a name="l00445"></a>00445 num ret;
<a name="l00446"></a>00446 <span class="keywordtype">long</span> e1, e2, res;
<a name="l00447"></a>00447 ret.is_fixnum=a.is_fixnum &amp;&amp; b.is_fixnum;
<a name="l00448"></a>00448 e1=num_ivalue(a);
<a name="l00449"></a>00449 e2=num_ivalue(b);
<a name="l00450"></a>00450 res=e1%e2;
<a name="l00451"></a>00451 <span class="comment">/* modulo should have same sign as second operand */</span>
<a name="l00452"></a>00452 <span class="keywordflow">if</span> (res &gt; 0) {
<a name="l00453"></a>00453 <span class="keywordflow">if</span> (e1 &lt; 0) {
<a name="l00454"></a>00454 res -= labs(e2);
<a name="l00455"></a>00455 }
<a name="l00456"></a>00456 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (res &lt; 0) {
<a name="l00457"></a>00457 <span class="keywordflow">if</span> (e1 &gt; 0) {
<a name="l00458"></a>00458 res += labs(e2);
<a name="l00459"></a>00459 }
<a name="l00460"></a>00460 }
<a name="l00461"></a>00461 ret.value.ivalue=res;
<a name="l00462"></a>00462 <span class="keywordflow">return</span> ret;
<a name="l00463"></a>00463 }
<a name="l00464"></a>00464
<a name="l00465"></a>00465 <span class="keyword">static</span> num num_mod(num a, num b) {
<a name="l00466"></a>00466 num ret;
<a name="l00467"></a>00467 <span class="keywordtype">long</span> e1, e2, res;
<a name="l00468"></a>00468 ret.is_fixnum=a.is_fixnum &amp;&amp; b.is_fixnum;
<a name="l00469"></a>00469 e1=num_ivalue(a);
<a name="l00470"></a>00470 e2=num_ivalue(b);
<a name="l00471"></a>00471 res=e1%e2;
<a name="l00472"></a>00472 <span class="keywordflow">if</span>(res*e2&lt;0) { <span class="comment">/* modulo should have same sign as second operand */</span>
<a name="l00473"></a>00473 e2=labs(e2);
<a name="l00474"></a>00474 <span class="keywordflow">if</span>(res&gt;0) {
<a name="l00475"></a>00475 res-=e2;
<a name="l00476"></a>00476 } <span class="keywordflow">else</span> {
<a name="l00477"></a>00477 res+=e2;
<a name="l00478"></a>00478 }
<a name="l00479"></a>00479 }
<a name="l00480"></a>00480 ret.value.ivalue=res;
<a name="l00481"></a>00481 <span class="keywordflow">return</span> ret;
<a name="l00482"></a>00482 }
<a name="l00483"></a>00483
<a name="l00484"></a>00484 <span class="keyword">static</span> <span class="keywordtype">int</span> num_eq(num a, num b) {
<a name="l00485"></a>00485 <span class="keywordtype">int</span> ret;
<a name="l00486"></a>00486 <span class="keywordtype">int</span> is_fixnum=a.is_fixnum &amp;&amp; b.is_fixnum;
<a name="l00487"></a>00487 <span class="keywordflow">if</span>(is_fixnum) {
<a name="l00488"></a>00488 ret= a.value.ivalue==b.value.ivalue;
<a name="l00489"></a>00489 } <span class="keywordflow">else</span> {
<a name="l00490"></a>00490 ret=num_rvalue(a)==num_rvalue(b);
<a name="l00491"></a>00491 }
<a name="l00492"></a>00492 <span class="keywordflow">return</span> ret;
<a name="l00493"></a>00493 }
<a name="l00494"></a>00494
<a name="l00495"></a>00495
<a name="l00496"></a>00496 <span class="keyword">static</span> <span class="keywordtype">int</span> num_gt(num a, num b) {
<a name="l00497"></a>00497 <span class="keywordtype">int</span> ret;
<a name="l00498"></a>00498 <span class="keywordtype">int</span> is_fixnum=a.is_fixnum &amp;&amp; b.is_fixnum;
<a name="l00499"></a>00499 <span class="keywordflow">if</span>(is_fixnum) {
<a name="l00500"></a>00500 ret= a.value.ivalue&gt;b.value.ivalue;
<a name="l00501"></a>00501 } <span class="keywordflow">else</span> {
<a name="l00502"></a>00502 ret=num_rvalue(a)&gt;num_rvalue(b);
<a name="l00503"></a>00503 }
<a name="l00504"></a>00504 <span class="keywordflow">return</span> ret;
<a name="l00505"></a>00505 }
<a name="l00506"></a>00506
<a name="l00507"></a>00507 <span class="keyword">static</span> <span class="keywordtype">int</span> num_ge(num a, num b) {
<a name="l00508"></a>00508 <span class="keywordflow">return</span> !num_lt(a,b);
<a name="l00509"></a>00509 }
<a name="l00510"></a>00510
<a name="l00511"></a>00511 <span class="keyword">static</span> <span class="keywordtype">int</span> num_lt(num a, num b) {
<a name="l00512"></a>00512 <span class="keywordtype">int</span> ret;
<a name="l00513"></a>00513 <span class="keywordtype">int</span> is_fixnum=a.is_fixnum &amp;&amp; b.is_fixnum;
<a name="l00514"></a>00514 <span class="keywordflow">if</span>(is_fixnum) {
<a name="l00515"></a>00515 ret= a.value.ivalue&lt;b.value.ivalue;
<a name="l00516"></a>00516 } <span class="keywordflow">else</span> {
<a name="l00517"></a>00517 ret=num_rvalue(a)&lt;num_rvalue(b);
<a name="l00518"></a>00518 }
<a name="l00519"></a>00519 <span class="keywordflow">return</span> ret;
<a name="l00520"></a>00520 }
<a name="l00521"></a>00521
<a name="l00522"></a>00522 <span class="keyword">static</span> <span class="keywordtype">int</span> num_le(num a, num b) {
<a name="l00523"></a>00523 <span class="keywordflow">return</span> !num_gt(a,b);
<a name="l00524"></a>00524 }
<a name="l00525"></a>00525
<a name="l00526"></a>00526 <span class="preprocessor">#if USE_MATH</span>
<a name="l00527"></a>00527 <span class="preprocessor"></span><span class="comment">/* Round to nearest. Round to even if midway */</span>
<a name="l00528"></a>00528 <span class="keyword">static</span> <span class="keywordtype">double</span> round_per_R5RS(<span class="keywordtype">double</span> x) {
<a name="l00529"></a>00529 <span class="keywordtype">double</span> fl=floor(x);
<a name="l00530"></a>00530 <span class="keywordtype">double</span> ce=ceil(x);
<a name="l00531"></a>00531 <span class="keywordtype">double</span> dfl=x-fl;
<a name="l00532"></a>00532 <span class="keywordtype">double</span> dce=ce-x;
<a name="l00533"></a>00533 <span class="keywordflow">if</span>(dfl&gt;dce) {
<a name="l00534"></a>00534 <span class="keywordflow">return</span> ce;
<a name="l00535"></a>00535 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(dfl&lt;dce) {
<a name="l00536"></a>00536 <span class="keywordflow">return</span> fl;
<a name="l00537"></a>00537 } <span class="keywordflow">else</span> {
<a name="l00538"></a>00538 <span class="keywordflow">if</span>(fmod(fl,2.0)==0.0) { <span class="comment">/* I imagine this holds */</span>
<a name="l00539"></a>00539 <span class="keywordflow">return</span> fl;
<a name="l00540"></a>00540 } <span class="keywordflow">else</span> {
<a name="l00541"></a>00541 <span class="keywordflow">return</span> ce;
<a name="l00542"></a>00542 }
<a name="l00543"></a>00543 }
<a name="l00544"></a>00544 }
<a name="l00545"></a>00545 <span class="preprocessor">#endif</span>
<a name="l00546"></a>00546 <span class="preprocessor"></span>
<a name="l00547"></a>00547 <span class="keyword">static</span> <span class="keywordtype">int</span> is_zero_double(<span class="keywordtype">double</span> x) {
<a name="l00548"></a>00548 <span class="keywordflow">return</span> x&lt;DBL_MIN &amp;&amp; x&gt;-DBL_MIN;
<a name="l00549"></a>00549 }
<a name="l00550"></a>00550
<a name="l00551"></a>00551 <span class="keyword">static</span> <span class="keywordtype">long</span> binary_decode(<span class="keyword">const</span> <span class="keywordtype">char</span> *s) {
<a name="l00552"></a>00552 <span class="keywordtype">long</span> x=0;
<a name="l00553"></a>00553
<a name="l00554"></a>00554 <span class="keywordflow">while</span>(*s!=0 &amp;&amp; (*s==<span class="charliteral">'1'</span> || *s==<span class="charliteral">'0'</span>)) {
<a name="l00555"></a>00555 x&lt;&lt;=1;
<a name="l00556"></a>00556 x+=*s-<span class="charliteral">'0'</span>;
<a name="l00557"></a>00557 s++;
<a name="l00558"></a>00558 }
<a name="l00559"></a>00559
<a name="l00560"></a>00560 <span class="keywordflow">return</span> x;
<a name="l00561"></a>00561 }
<a name="l00562"></a>00562
<a name="l00563"></a>00563 <span class="comment">/* allocate new cell segment */</span>
<a name="l00564"></a>00564 <span class="keyword">static</span> <span class="keywordtype">int</span> alloc_cellseg(scheme *sc, <span class="keywordtype">int</span> n) {
<a name="l00565"></a>00565 pointer newp;
<a name="l00566"></a>00566 pointer last;
<a name="l00567"></a>00567 pointer p;
<a name="l00568"></a>00568 <span class="keywordtype">char</span> *cp;
<a name="l00569"></a>00569 <span class="keywordtype">long</span> i;
<a name="l00570"></a>00570 <span class="keywordtype">int</span> k;
<a name="l00571"></a>00571 <span class="keywordtype">int</span> adj=ADJ;
<a name="l00572"></a>00572
<a name="l00573"></a>00573 <span class="keywordflow">if</span>(adj&lt;<span class="keyword">sizeof</span>(<span class="keyword">struct</span> cell)) {
<a name="l00574"></a>00574 adj=<span class="keyword">sizeof</span>(<span class="keyword">struct </span>cell);
<a name="l00575"></a>00575 }
<a name="l00576"></a>00576
<a name="l00577"></a>00577 <span class="keywordflow">for</span> (k = 0; k &lt; n; k++) {
<a name="l00578"></a>00578 <span class="keywordflow">if</span> (sc-&gt;last_cell_seg &gt;= CELL_NSEGMENT - 1)
<a name="l00579"></a>00579 <span class="keywordflow">return</span> k;
<a name="l00580"></a>00580 cp = (<span class="keywordtype">char</span>*) sc-&gt;malloc(CELL_SEGSIZE * <span class="keyword">sizeof</span>(<span class="keyword">struct</span> cell)+adj);
<a name="l00581"></a>00581 <span class="keywordflow">if</span> (cp == 0)
<a name="l00582"></a>00582 <span class="keywordflow">return</span> k;
<a name="l00583"></a>00583 i = ++sc-&gt;last_cell_seg ;
<a name="l00584"></a>00584 sc-&gt;alloc_seg[i] = cp;
<a name="l00585"></a>00585 <span class="comment">/* adjust in TYPE_BITS-bit boundary */</span>
<a name="l00586"></a>00586 <span class="keywordflow">if</span>((<span class="keywordtype">unsigned</span> <span class="keywordtype">long</span>)cp%adj!=0) {
<a name="l00587"></a>00587 cp=(<span class="keywordtype">char</span>*)(adj*((<span class="keywordtype">unsigned</span> <span class="keywordtype">long</span>)cp/adj+1));
<a name="l00588"></a>00588 }
<a name="l00589"></a>00589 <span class="comment">/* insert new segment in address order */</span>
<a name="l00590"></a>00590 newp=(pointer)cp;
<a name="l00591"></a>00591 sc-&gt;cell_seg[i] = newp;
<a name="l00592"></a>00592 <span class="keywordflow">while</span> (i &gt; 0 &amp;&amp; sc-&gt;cell_seg[i - 1] &gt; sc-&gt;cell_seg[i]) {
<a name="l00593"></a>00593 p = sc-&gt;cell_seg[i];
<a name="l00594"></a>00594 sc-&gt;cell_seg[i] = sc-&gt;cell_seg[i - 1];
<a name="l00595"></a>00595 sc-&gt;cell_seg[--i] = p;
<a name="l00596"></a>00596 }
<a name="l00597"></a>00597 sc-&gt;fcells += CELL_SEGSIZE;
<a name="l00598"></a>00598 last = newp + CELL_SEGSIZE - 1;
<a name="l00599"></a>00599 <span class="keywordflow">for</span> (p = newp; p &lt;= last; p++) {
<a name="l00600"></a>00600 typeflag(p) = 0;
<a name="l00601"></a>00601 cdr(p) = p + 1;
<a name="l00602"></a>00602 car(p) = sc-&gt;NIL;
<a name="l00603"></a>00603 }
<a name="l00604"></a>00604 <span class="comment">/* insert new cells in address order on free list */</span>
<a name="l00605"></a>00605 <span class="keywordflow">if</span> (sc-&gt;free_cell == sc-&gt;NIL || p &lt; sc-&gt;free_cell) {
<a name="l00606"></a>00606 cdr(last) = sc-&gt;free_cell;
<a name="l00607"></a>00607 sc-&gt;free_cell = newp;
<a name="l00608"></a>00608 } <span class="keywordflow">else</span> {
<a name="l00609"></a>00609 p = sc-&gt;free_cell;
<a name="l00610"></a>00610 <span class="keywordflow">while</span> (cdr(p) != sc-&gt;NIL &amp;&amp; newp &gt; cdr(p))
<a name="l00611"></a>00611 p = cdr(p);
<a name="l00612"></a>00612 cdr(last) = cdr(p);
<a name="l00613"></a>00613 cdr(p) = newp;
<a name="l00614"></a>00614 }
<a name="l00615"></a>00615 }
<a name="l00616"></a>00616 <span class="keywordflow">return</span> n;
<a name="l00617"></a>00617 }
<a name="l00618"></a>00618
<a name="l00619"></a>00619 <span class="keyword">static</span> INLINE pointer get_cell(scheme *sc, pointer a, pointer b) {
<a name="l00620"></a>00620 <span class="keywordflow">if</span> (sc-&gt;free_cell != sc-&gt;NIL) {
<a name="l00621"></a>00621 pointer x = sc-&gt;free_cell;
<a name="l00622"></a>00622 sc-&gt;free_cell = cdr(x);
<a name="l00623"></a>00623 --sc-&gt;fcells;
<a name="l00624"></a>00624 <span class="keywordflow">return</span> (x);
<a name="l00625"></a>00625 }
<a name="l00626"></a>00626 <span class="keywordflow">return</span> _get_cell (sc, a, b);
<a name="l00627"></a>00627 }
<a name="l00628"></a>00628
<a name="l00629"></a>00629
<a name="l00630"></a>00630 <span class="comment">/* get new cell. parameter a, b is marked by gc. */</span>
<a name="l00631"></a>00631 <span class="keyword">static</span> pointer _get_cell(scheme *sc, pointer a, pointer b) {
<a name="l00632"></a>00632 pointer x;
<a name="l00633"></a>00633
<a name="l00634"></a>00634 <span class="keywordflow">if</span>(sc-&gt;no_memory) {
<a name="l00635"></a>00635 <span class="keywordflow">return</span> sc-&gt;sink;
<a name="l00636"></a>00636 }
<a name="l00637"></a>00637
<a name="l00638"></a>00638 <span class="keywordflow">if</span> (sc-&gt;free_cell == sc-&gt;NIL) {
<a name="l00639"></a>00639 gc(sc,a, b);
<a name="l00640"></a>00640 <span class="keywordflow">if</span> (sc-&gt;fcells &lt; sc-&gt;last_cell_seg*8
<a name="l00641"></a>00641 || sc-&gt;free_cell == sc-&gt;NIL) {
<a name="l00642"></a>00642 <span class="comment">/* if only a few recovered, get more to avoid fruitless gc's */</span>
<a name="l00643"></a>00643 <span class="keywordflow">if</span> (!alloc_cellseg(sc,1) &amp;&amp; sc-&gt;free_cell == sc-&gt;NIL) {
<a name="l00644"></a>00644 sc-&gt;no_memory=1;
<a name="l00645"></a>00645 <span class="keywordflow">return</span> sc-&gt;sink;
<a name="l00646"></a>00646 }
<a name="l00647"></a>00647 }
<a name="l00648"></a>00648 }
<a name="l00649"></a>00649 x = sc-&gt;free_cell;
<a name="l00650"></a>00650 sc-&gt;free_cell = cdr(x);
<a name="l00651"></a>00651 --sc-&gt;fcells;
<a name="l00652"></a>00652 <span class="keywordflow">return</span> (x);
<a name="l00653"></a>00653 }
<a name="l00654"></a>00654
<a name="l00655"></a>00655 <span class="keyword">static</span> pointer get_consecutive_cells(scheme *sc, <span class="keywordtype">int</span> n) {
<a name="l00656"></a>00656 pointer x;
<a name="l00657"></a>00657
<a name="l00658"></a>00658 <span class="keywordflow">if</span>(sc-&gt;no_memory) {
<a name="l00659"></a>00659 <span class="keywordflow">return</span> sc-&gt;sink;
<a name="l00660"></a>00660 }
<a name="l00661"></a>00661
<a name="l00662"></a>00662 <span class="comment">/* Are there any cells available? */</span>
<a name="l00663"></a>00663 x=find_consecutive_cells(sc,n);
<a name="l00664"></a>00664 <span class="keywordflow">if</span> (x == sc-&gt;NIL) {
<a name="l00665"></a>00665 <span class="comment">/* If not, try gc'ing some */</span>
<a name="l00666"></a>00666 gc(sc, sc-&gt;NIL, sc-&gt;NIL);
<a name="l00667"></a>00667 x=find_consecutive_cells(sc,n);
<a name="l00668"></a>00668 <span class="keywordflow">if</span> (x == sc-&gt;NIL) {
<a name="l00669"></a>00669 <span class="comment">/* If there still aren't, try getting more heap */</span>
<a name="l00670"></a>00670 <span class="keywordflow">if</span> (!alloc_cellseg(sc,1)) {
<a name="l00671"></a>00671 sc-&gt;no_memory=1;
<a name="l00672"></a>00672 <span class="keywordflow">return</span> sc-&gt;sink;
<a name="l00673"></a>00673 }
<a name="l00674"></a>00674 }
<a name="l00675"></a>00675 x=find_consecutive_cells(sc,n);
<a name="l00676"></a>00676 <span class="keywordflow">if</span> (x == sc-&gt;NIL) {
<a name="l00677"></a>00677 <span class="comment">/* If all fail, report failure */</span>
<a name="l00678"></a>00678 sc-&gt;no_memory=1;
<a name="l00679"></a>00679 <span class="keywordflow">return</span> sc-&gt;sink;
<a name="l00680"></a>00680 }
<a name="l00681"></a>00681 }
<a name="l00682"></a>00682 <span class="keywordflow">return</span> (x);
<a name="l00683"></a>00683 }
<a name="l00684"></a>00684
<a name="l00685"></a>00685 <span class="keyword">static</span> <span class="keywordtype">int</span> count_consecutive_cells(pointer x, <span class="keywordtype">int</span> needed) {
<a name="l00686"></a>00686 <span class="keywordtype">int</span> n=1;
<a name="l00687"></a>00687 <span class="keywordflow">while</span>(cdr(x)==x+1) {
<a name="l00688"></a>00688 x=cdr(x);
<a name="l00689"></a>00689 n++;
<a name="l00690"></a>00690 <span class="keywordflow">if</span>(n&gt;needed) <span class="keywordflow">return</span> n;
<a name="l00691"></a>00691 }
<a name="l00692"></a>00692 <span class="keywordflow">return</span> n;
<a name="l00693"></a>00693 }
<a name="l00694"></a>00694
<a name="l00695"></a>00695 <span class="keyword">static</span> pointer find_consecutive_cells(scheme *sc, <span class="keywordtype">int</span> n) {
<a name="l00696"></a>00696 pointer *pp;
<a name="l00697"></a>00697 <span class="keywordtype">int</span> cnt;
<a name="l00698"></a>00698
<a name="l00699"></a>00699 pp=&amp;sc-&gt;free_cell;
<a name="l00700"></a>00700 <span class="keywordflow">while</span>(*pp!=sc-&gt;NIL) {
<a name="l00701"></a>00701 cnt=count_consecutive_cells(*pp,n);
<a name="l00702"></a>00702 <span class="keywordflow">if</span>(cnt&gt;=n) {
<a name="l00703"></a>00703 pointer x=*pp;
<a name="l00704"></a>00704 *pp=cdr(*pp+n-1);
<a name="l00705"></a>00705 sc-&gt;fcells -= n;
<a name="l00706"></a>00706 <span class="keywordflow">return</span> x;
<a name="l00707"></a>00707 }
<a name="l00708"></a>00708 pp=&amp;cdr(*pp+cnt-1);
<a name="l00709"></a>00709 }
<a name="l00710"></a>00710 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l00711"></a>00711 }
<a name="l00712"></a>00712
<a name="l00713"></a>00713 <span class="comment">/* get new cons cell */</span>
<a name="l00714"></a>00714 pointer _cons(scheme *sc, pointer a, pointer b, <span class="keywordtype">int</span> immutable) {
<a name="l00715"></a>00715 pointer x = get_cell(sc,a, b);
<a name="l00716"></a>00716
<a name="l00717"></a>00717 typeflag(x) = T_PAIR;
<a name="l00718"></a>00718 <span class="keywordflow">if</span>(immutable) {
<a name="l00719"></a>00719 setimmutable(x);
<a name="l00720"></a>00720 }
<a name="l00721"></a>00721 car(x) = a;
<a name="l00722"></a>00722 cdr(x) = b;
<a name="l00723"></a>00723 <span class="keywordflow">return</span> (x);
<a name="l00724"></a>00724 }
<a name="l00725"></a>00725
<a name="l00726"></a>00726 <span class="comment">/* ========== oblist implementation ========== */</span>
<a name="l00727"></a>00727
<a name="l00728"></a>00728 <span class="preprocessor">#ifndef USE_OBJECT_LIST </span>
<a name="l00729"></a>00729 <span class="preprocessor"></span>
<a name="l00730"></a>00730 <span class="keyword">static</span> <span class="keywordtype">int</span> hash_fn(<span class="keyword">const</span> <span class="keywordtype">char</span> *key, <span class="keywordtype">int</span> table_size);
<a name="l00731"></a>00731
<a name="l00732"></a>00732 <span class="keyword">static</span> pointer oblist_initial_value(scheme *sc)
<a name="l00733"></a>00733 {
<a name="l00734"></a>00734 <span class="keywordflow">return</span> mk_vector(sc, 461); <span class="comment">/* probably should be bigger */</span>
<a name="l00735"></a>00735 }
<a name="l00736"></a>00736
<a name="l00737"></a>00737 <span class="comment">/* returns the new symbol */</span>
<a name="l00738"></a>00738 <span class="keyword">static</span> pointer oblist_add_by_name(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *name)
<a name="l00739"></a>00739 {
<a name="l00740"></a>00740 pointer x;
<a name="l00741"></a>00741 <span class="keywordtype">int</span> location;
<a name="l00742"></a>00742
<a name="l00743"></a>00743 x = immutable_cons(sc, mk_string(sc, name), sc-&gt;NIL);
<a name="l00744"></a>00744 typeflag(x) = T_SYMBOL;
<a name="l00745"></a>00745 setimmutable(car(x));
<a name="l00746"></a>00746
<a name="l00747"></a>00747 location = hash_fn(name, ivalue_unchecked(sc-&gt;oblist));
<a name="l00748"></a>00748 set_vector_elem(sc-&gt;oblist, location,
<a name="l00749"></a>00749 immutable_cons(sc, x, vector_elem(sc-&gt;oblist, location)));
<a name="l00750"></a>00750 <span class="keywordflow">return</span> x;
<a name="l00751"></a>00751 }
<a name="l00752"></a>00752
<a name="l00753"></a>00753 <span class="keyword">static</span> INLINE pointer oblist_find_by_name(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *name)
<a name="l00754"></a>00754 {
<a name="l00755"></a>00755 <span class="keywordtype">int</span> location;
<a name="l00756"></a>00756 pointer x;
<a name="l00757"></a>00757 <span class="keywordtype">char</span> *s;
<a name="l00758"></a>00758
<a name="l00759"></a>00759 location = hash_fn(name, ivalue_unchecked(sc-&gt;oblist));
<a name="l00760"></a>00760 <span class="keywordflow">for</span> (x = vector_elem(sc-&gt;oblist, location); x != sc-&gt;NIL; x = cdr(x)) {
<a name="l00761"></a>00761 s = symname(car(x));
<a name="l00762"></a>00762 <span class="comment">/* case-insensitive, per R5RS section 2. */</span>
<a name="l00763"></a>00763 <span class="keywordflow">if</span>(stricmp(name, s) == 0) {
<a name="l00764"></a>00764 <span class="keywordflow">return</span> car(x);
<a name="l00765"></a>00765 }
<a name="l00766"></a>00766 }
<a name="l00767"></a>00767 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l00768"></a>00768 }
<a name="l00769"></a>00769
<a name="l00770"></a>00770 <span class="keyword">static</span> pointer oblist_all_symbols(scheme *sc)
<a name="l00771"></a>00771 {
<a name="l00772"></a>00772 <span class="keywordtype">int</span> i;
<a name="l00773"></a>00773 pointer x;
<a name="l00774"></a>00774 pointer ob_list = sc-&gt;NIL;
<a name="l00775"></a>00775
<a name="l00776"></a>00776 <span class="keywordflow">for</span> (i = 0; i &lt; ivalue_unchecked(sc-&gt;oblist); i++) {
<a name="l00777"></a>00777 <span class="keywordflow">for</span> (x = vector_elem(sc-&gt;oblist, i); x != sc-&gt;NIL; x = cdr(x)) {
<a name="l00778"></a>00778 ob_list = cons(sc, x, ob_list);
<a name="l00779"></a>00779 }
<a name="l00780"></a>00780 }
<a name="l00781"></a>00781 <span class="keywordflow">return</span> ob_list;
<a name="l00782"></a>00782 }
<a name="l00783"></a>00783
<a name="l00784"></a>00784 <span class="preprocessor">#else </span>
<a name="l00785"></a>00785 <span class="preprocessor"></span>
<a name="l00786"></a>00786 <span class="keyword">static</span> pointer oblist_initial_value(scheme *sc)
<a name="l00787"></a>00787 {
<a name="l00788"></a>00788 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l00789"></a>00789 }
<a name="l00790"></a>00790
<a name="l00791"></a>00791 <span class="keyword">static</span> INLINE pointer oblist_find_by_name(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *name)
<a name="l00792"></a>00792 {
<a name="l00793"></a>00793 pointer x;
<a name="l00794"></a>00794 <span class="keywordtype">char</span> *s;
<a name="l00795"></a>00795
<a name="l00796"></a>00796 <span class="keywordflow">for</span> (x = sc-&gt;oblist; x != sc-&gt;NIL; x = cdr(x)) {
<a name="l00797"></a>00797 s = symname(car(x));
<a name="l00798"></a>00798 <span class="comment">/* case-insensitive, per R5RS section 2. */</span>
<a name="l00799"></a>00799 <span class="keywordflow">if</span>(stricmp(name, s) == 0) {
<a name="l00800"></a>00800 <span class="keywordflow">return</span> car(x);
<a name="l00801"></a>00801 }
<a name="l00802"></a>00802 }
<a name="l00803"></a>00803 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l00804"></a>00804 }
<a name="l00805"></a>00805
<a name="l00806"></a>00806 <span class="comment">/* returns the new symbol */</span>
<a name="l00807"></a>00807 <span class="keyword">static</span> pointer oblist_add_by_name(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *name)
<a name="l00808"></a>00808 {
<a name="l00809"></a>00809 pointer x;
<a name="l00810"></a>00810
<a name="l00811"></a>00811 x = immutable_cons(sc, mk_string(sc, name), sc-&gt;NIL);
<a name="l00812"></a>00812 typeflag(x) = T_SYMBOL;
<a name="l00813"></a>00813 setimmutable(car(x));
<a name="l00814"></a>00814 sc-&gt;oblist = immutable_cons(sc, x, sc-&gt;oblist);
<a name="l00815"></a>00815 <span class="keywordflow">return</span> x;
<a name="l00816"></a>00816 }
<a name="l00817"></a>00817 <span class="keyword">static</span> pointer oblist_all_symbols(scheme *sc)
<a name="l00818"></a>00818 {
<a name="l00819"></a>00819 <span class="keywordflow">return</span> sc-&gt;oblist;
<a name="l00820"></a>00820 }
<a name="l00821"></a>00821
<a name="l00822"></a>00822 <span class="preprocessor">#endif </span>
<a name="l00823"></a>00823 <span class="preprocessor"></span>
<a name="l00824"></a>00824 <span class="keyword">static</span> pointer mk_port(scheme *sc, port *p) {
<a name="l00825"></a>00825 pointer x = get_cell(sc, sc-&gt;NIL, sc-&gt;NIL);
<a name="l00826"></a>00826
<a name="l00827"></a>00827 typeflag(x) = T_PORT|T_ATOM;
<a name="l00828"></a>00828 x-&gt;_object._port=p;
<a name="l00829"></a>00829 <span class="keywordflow">return</span> (x);
<a name="l00830"></a>00830 }
<a name="l00831"></a>00831
<a name="l00832"></a>00832 pointer mk_foreign_func(scheme *sc, foreign_func f) {
<a name="l00833"></a>00833 pointer x = get_cell(sc, sc-&gt;NIL, sc-&gt;NIL);
<a name="l00834"></a>00834
<a name="l00835"></a>00835 typeflag(x) = (T_FOREIGN | T_ATOM);
<a name="l00836"></a>00836 x-&gt;_object._ff=f;
<a name="l00837"></a>00837 <span class="keywordflow">return</span> (x);
<a name="l00838"></a>00838 }
<a name="l00839"></a>00839
<a name="l00840"></a>00840 INTERFACE pointer mk_character(scheme *sc, <span class="keywordtype">int</span> c) {
<a name="l00841"></a>00841 pointer x = get_cell(sc,sc-&gt;NIL, sc-&gt;NIL);
<a name="l00842"></a>00842
<a name="l00843"></a>00843 typeflag(x) = (T_CHARACTER | T_ATOM);
<a name="l00844"></a>00844 ivalue_unchecked(x)= c;
<a name="l00845"></a>00845 set_integer(x);
<a name="l00846"></a>00846 <span class="keywordflow">return</span> (x);
<a name="l00847"></a>00847 }
<a name="l00848"></a>00848
<a name="l00849"></a>00849 <span class="comment">/* get number atom (integer) */</span>
<a name="l00850"></a>00850 INTERFACE pointer mk_integer(scheme *sc, <span class="keywordtype">long</span> num) {
<a name="l00851"></a>00851 pointer x = get_cell(sc,sc-&gt;NIL, sc-&gt;NIL);
<a name="l00852"></a>00852
<a name="l00853"></a>00853 typeflag(x) = (T_NUMBER | T_ATOM);
<a name="l00854"></a>00854 ivalue_unchecked(x)= num;
<a name="l00855"></a>00855 set_integer(x);
<a name="l00856"></a>00856 <span class="keywordflow">return</span> (x);
<a name="l00857"></a>00857 }
<a name="l00858"></a>00858
<a name="l00859"></a>00859 INTERFACE pointer mk_real(scheme *sc, <span class="keywordtype">double</span> n) {
<a name="l00860"></a>00860 pointer x = get_cell(sc,sc-&gt;NIL, sc-&gt;NIL);
<a name="l00861"></a>00861
<a name="l00862"></a>00862 typeflag(x) = (T_NUMBER | T_ATOM);
<a name="l00863"></a>00863 rvalue_unchecked(x)= n;
<a name="l00864"></a>00864 set_real(x);
<a name="l00865"></a>00865 <span class="keywordflow">return</span> (x);
<a name="l00866"></a>00866 }
<a name="l00867"></a>00867
<a name="l00868"></a>00868 <span class="keyword">static</span> pointer mk_number(scheme *sc, num n) {
<a name="l00869"></a>00869 <span class="keywordflow">if</span>(n.is_fixnum) {
<a name="l00870"></a>00870 <span class="keywordflow">return</span> mk_integer(sc,n.value.ivalue);
<a name="l00871"></a>00871 } <span class="keywordflow">else</span> {
<a name="l00872"></a>00872 <span class="keywordflow">return</span> mk_real(sc,n.value.rvalue);
<a name="l00873"></a>00873 }
<a name="l00874"></a>00874 }
<a name="l00875"></a>00875
<a name="l00876"></a>00876 <span class="comment">/* allocate name to string area */</span>
<a name="l00877"></a>00877 <span class="keyword">static</span> <span class="keywordtype">char</span> *store_string(scheme *sc, <span class="keywordtype">int</span> len_str, <span class="keyword">const</span> <span class="keywordtype">char</span> *str, <span class="keywordtype">char</span> fill) {
<a name="l00878"></a>00878 <span class="keywordtype">char</span> *q;
<a name="l00879"></a>00879
<a name="l00880"></a>00880 q=(<span class="keywordtype">char</span>*)sc-&gt;malloc(len_str+1);
<a name="l00881"></a>00881 <span class="keywordflow">if</span>(q==0) {
<a name="l00882"></a>00882 sc-&gt;no_memory=1;
<a name="l00883"></a>00883 <span class="keywordflow">return</span> sc-&gt;strbuff;
<a name="l00884"></a>00884 }
<a name="l00885"></a>00885 <span class="keywordflow">if</span>(str!=0) {
<a name="l00886"></a>00886 strcpy(q, str);
<a name="l00887"></a>00887 } <span class="keywordflow">else</span> {
<a name="l00888"></a>00888 memset(q, fill, len_str);
<a name="l00889"></a>00889 q[len_str]=0;
<a name="l00890"></a>00890 }
<a name="l00891"></a>00891 <span class="keywordflow">return</span> (q);
<a name="l00892"></a>00892 }
<a name="l00893"></a>00893
<a name="l00894"></a>00894 <span class="comment">/* get new string */</span>
<a name="l00895"></a>00895 INTERFACE pointer mk_string(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *str) {
<a name="l00896"></a>00896 <span class="keywordflow">return</span> mk_counted_string(sc,str,strlen(str));
<a name="l00897"></a>00897 }
<a name="l00898"></a>00898
<a name="l00899"></a>00899 INTERFACE pointer mk_counted_string(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *str, <span class="keywordtype">int</span> len) {
<a name="l00900"></a>00900 pointer x = get_cell(sc, sc-&gt;NIL, sc-&gt;NIL);
<a name="l00901"></a>00901
<a name="l00902"></a>00902 strvalue(x) = store_string(sc,len,str,0);
<a name="l00903"></a>00903 typeflag(x) = (T_STRING | T_ATOM);
<a name="l00904"></a>00904 strlength(x) = len;
<a name="l00905"></a>00905 <span class="keywordflow">return</span> (x);
<a name="l00906"></a>00906 }
<a name="l00907"></a>00907
<a name="l00908"></a>00908 <span class="keyword">static</span> pointer mk_empty_string(scheme *sc, <span class="keywordtype">int</span> len, <span class="keywordtype">char</span> fill) {
<a name="l00909"></a>00909 pointer x = get_cell(sc, sc-&gt;NIL, sc-&gt;NIL);
<a name="l00910"></a>00910
<a name="l00911"></a>00911 strvalue(x) = store_string(sc,len,0,fill);
<a name="l00912"></a>00912 typeflag(x) = (T_STRING | T_ATOM);
<a name="l00913"></a>00913 strlength(x) = len;
<a name="l00914"></a>00914 <span class="keywordflow">return</span> (x);
<a name="l00915"></a>00915 }
<a name="l00916"></a>00916
<a name="l00917"></a>00917 INTERFACE <span class="keyword">static</span> pointer mk_vector(scheme *sc, <span class="keywordtype">int</span> len) {
<a name="l00918"></a>00918 pointer x=get_consecutive_cells(sc,len/2+len%2+1);
<a name="l00919"></a>00919 typeflag(x) = (T_VECTOR | T_ATOM);
<a name="l00920"></a>00920 ivalue_unchecked(x)=len;
<a name="l00921"></a>00921 set_integer(x);
<a name="l00922"></a>00922 fill_vector(x,sc-&gt;NIL);
<a name="l00923"></a>00923 <span class="keywordflow">return</span> x;
<a name="l00924"></a>00924 }
<a name="l00925"></a>00925
<a name="l00926"></a>00926 INTERFACE <span class="keyword">static</span> <span class="keywordtype">void</span> fill_vector(pointer vec, pointer obj) {
<a name="l00927"></a>00927 <span class="keywordtype">int</span> i;
<a name="l00928"></a>00928 <span class="keywordtype">int</span> num=ivalue(vec)/2+ivalue(vec)%2;
<a name="l00929"></a>00929 <span class="keywordflow">for</span>(i=0; i&lt;num; i++) {
<a name="l00930"></a>00930 typeflag(vec+1+i) = T_PAIR;
<a name="l00931"></a>00931 setimmutable(vec+1+i);
<a name="l00932"></a>00932 car(vec+1+i)=obj;
<a name="l00933"></a>00933 cdr(vec+1+i)=obj;
<a name="l00934"></a>00934 }
<a name="l00935"></a>00935 }
<a name="l00936"></a>00936
<a name="l00937"></a>00937 INTERFACE <span class="keyword">static</span> pointer vector_elem(pointer vec, <span class="keywordtype">int</span> ielem) {
<a name="l00938"></a>00938 <span class="keywordtype">int</span> n=ielem/2;
<a name="l00939"></a>00939 <span class="keywordflow">if</span>(ielem%2==0) {
<a name="l00940"></a>00940 <span class="keywordflow">return</span> car(vec+1+n);
<a name="l00941"></a>00941 } <span class="keywordflow">else</span> {
<a name="l00942"></a>00942 <span class="keywordflow">return</span> cdr(vec+1+n);
<a name="l00943"></a>00943 }
<a name="l00944"></a>00944 }
<a name="l00945"></a>00945
<a name="l00946"></a>00946 INTERFACE <span class="keyword">static</span> pointer set_vector_elem(pointer vec, <span class="keywordtype">int</span> ielem, pointer a) {
<a name="l00947"></a>00947 <span class="keywordtype">int</span> n=ielem/2;
<a name="l00948"></a>00948 <span class="keywordflow">if</span>(ielem%2==0) {
<a name="l00949"></a>00949 <span class="keywordflow">return</span> car(vec+1+n)=a;
<a name="l00950"></a>00950 } <span class="keywordflow">else</span> {
<a name="l00951"></a>00951 <span class="keywordflow">return</span> cdr(vec+1+n)=a;
<a name="l00952"></a>00952 }
<a name="l00953"></a>00953 }
<a name="l00954"></a>00954
<a name="l00955"></a>00955 <span class="comment">/* get new symbol */</span>
<a name="l00956"></a>00956 INTERFACE pointer mk_symbol(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *name) {
<a name="l00957"></a>00957 pointer x;
<a name="l00958"></a>00958
<a name="l00959"></a>00959 <span class="comment">/* first check oblist */</span>
<a name="l00960"></a>00960 x = oblist_find_by_name(sc, name);
<a name="l00961"></a>00961 <span class="keywordflow">if</span> (x != sc-&gt;NIL) {
<a name="l00962"></a>00962 <span class="keywordflow">return</span> (x);
<a name="l00963"></a>00963 } <span class="keywordflow">else</span> {
<a name="l00964"></a>00964 x = oblist_add_by_name(sc, name);
<a name="l00965"></a>00965 <span class="keywordflow">return</span> (x);
<a name="l00966"></a>00966 }
<a name="l00967"></a>00967 }
<a name="l00968"></a>00968
<a name="l00969"></a>00969 INTERFACE pointer gensym(scheme *sc) {
<a name="l00970"></a>00970 pointer x;
<a name="l00971"></a>00971 <span class="keywordtype">char</span> name[40];
<a name="l00972"></a>00972
<a name="l00973"></a>00973 <span class="keywordflow">for</span>(; sc-&gt;gensym_cnt&lt;LONG_MAX; sc-&gt;gensym_cnt++) {
<a name="l00974"></a>00974 sprintf(name,<span class="stringliteral">"gensym-%ld"</span>,sc-&gt;gensym_cnt);
<a name="l00975"></a>00975
<a name="l00976"></a>00976 <span class="comment">/* first check oblist */</span>
<a name="l00977"></a>00977 x = oblist_find_by_name(sc, name);
<a name="l00978"></a>00978
<a name="l00979"></a>00979 <span class="keywordflow">if</span> (x != sc-&gt;NIL) {
<a name="l00980"></a>00980 <span class="keywordflow">continue</span>;
<a name="l00981"></a>00981 } <span class="keywordflow">else</span> {
<a name="l00982"></a>00982 x = oblist_add_by_name(sc, name);
<a name="l00983"></a>00983 <span class="keywordflow">return</span> (x);
<a name="l00984"></a>00984 }
<a name="l00985"></a>00985 }
<a name="l00986"></a>00986
<a name="l00987"></a>00987 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l00988"></a>00988 }
<a name="l00989"></a>00989
<a name="l00990"></a>00990 <span class="comment">/* make symbol or number atom from string */</span>
<a name="l00991"></a>00991 <span class="keyword">static</span> pointer mk_atom(scheme *sc, <span class="keywordtype">char</span> *q) {
<a name="l00992"></a>00992 <span class="keywordtype">char</span> c, *p;
<a name="l00993"></a>00993 <span class="keywordtype">int</span> has_dec_point=0;
<a name="l00994"></a>00994 <span class="keywordtype">int</span> has_fp_exp = 0;
<a name="l00995"></a>00995
<a name="l00996"></a>00996 <span class="preprocessor">#if USE_COLON_HOOK</span>
<a name="l00997"></a>00997 <span class="preprocessor"></span> <span class="keywordflow">if</span>((p=strstr(q,<span class="stringliteral">"::"</span>))!=0) {
<a name="l00998"></a>00998 *p=0;
<a name="l00999"></a>00999 <span class="keywordflow">return</span> cons(sc, sc-&gt;COLON_HOOK,
<a name="l01000"></a>01000 cons(sc,
<a name="l01001"></a>01001 cons(sc,
<a name="l01002"></a>01002 sc-&gt;QUOTE,
<a name="l01003"></a>01003 cons(sc, mk_atom(sc,p+2), sc-&gt;NIL)),
<a name="l01004"></a>01004 cons(sc, mk_symbol(sc,strlwr(q)), sc-&gt;NIL)));
<a name="l01005"></a>01005 }
<a name="l01006"></a>01006 <span class="preprocessor">#endif</span>
<a name="l01007"></a>01007 <span class="preprocessor"></span>
<a name="l01008"></a>01008 p = q;
<a name="l01009"></a>01009 c = *p++;
<a name="l01010"></a>01010 <span class="keywordflow">if</span> ((c == <span class="charliteral">'+'</span>) || (c == <span class="charliteral">'-'</span>)) {
<a name="l01011"></a>01011 c = *p++;
<a name="l01012"></a>01012 <span class="keywordflow">if</span> (c == <span class="charliteral">'.'</span>) {
<a name="l01013"></a>01013 has_dec_point=1;
<a name="l01014"></a>01014 c = *p++;
<a name="l01015"></a>01015 }
<a name="l01016"></a>01016 <span class="keywordflow">if</span> (!isdigit((<span class="keywordtype">int</span>) c)) {
<a name="l01017"></a>01017 <span class="keywordflow">return</span> (mk_symbol(sc, strlwr(q)));
<a name="l01018"></a>01018 }
<a name="l01019"></a>01019 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (c == <span class="charliteral">'.'</span>) {
<a name="l01020"></a>01020 has_dec_point=1;
<a name="l01021"></a>01021 c = *p++;
<a name="l01022"></a>01022 <span class="keywordflow">if</span> (!isdigit((<span class="keywordtype">int</span>) c)) {
<a name="l01023"></a>01023 <span class="keywordflow">return</span> (mk_symbol(sc, strlwr(q)));
<a name="l01024"></a>01024 }
<a name="l01025"></a>01025 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (!isdigit((<span class="keywordtype">int</span>) c)) {
<a name="l01026"></a>01026 <span class="keywordflow">return</span> (mk_symbol(sc, strlwr(q)));
<a name="l01027"></a>01027 }
<a name="l01028"></a>01028
<a name="l01029"></a>01029 <span class="keywordflow">for</span> ( ; (c = *p) != 0; ++p) {
<a name="l01030"></a>01030 <span class="keywordflow">if</span> (!isdigit((<span class="keywordtype">int</span>) c)) {
<a name="l01031"></a>01031 <span class="keywordflow">if</span>(c==<span class="charliteral">'.'</span>) {
<a name="l01032"></a>01032 <span class="keywordflow">if</span>(!has_dec_point) {
<a name="l01033"></a>01033 has_dec_point=1;
<a name="l01034"></a>01034 <span class="keywordflow">continue</span>;
<a name="l01035"></a>01035 }
<a name="l01036"></a>01036 }
<a name="l01037"></a>01037 <span class="keywordflow">else</span> <span class="keywordflow">if</span> ((c == <span class="charliteral">'e'</span>) || (c == <span class="charliteral">'E'</span>)) {
<a name="l01038"></a>01038 <span class="keywordflow">if</span>(!has_fp_exp) {
<a name="l01039"></a>01039 has_dec_point = 1; <span class="comment">/* decimal point illegal</span>
<a name="l01040"></a>01040 <span class="comment"> from now on */</span>
<a name="l01041"></a>01041 p++;
<a name="l01042"></a>01042 <span class="keywordflow">if</span> ((*p == <span class="charliteral">'-'</span>) || (*p == <span class="charliteral">'+'</span>) || isdigit((<span class="keywordtype">int</span>) *p)) {
<a name="l01043"></a>01043 <span class="keywordflow">continue</span>;
<a name="l01044"></a>01044 }
<a name="l01045"></a>01045 }
<a name="l01046"></a>01046 }
<a name="l01047"></a>01047 <span class="keywordflow">return</span> (mk_symbol(sc, strlwr(q)));
<a name="l01048"></a>01048 }
<a name="l01049"></a>01049 }
<a name="l01050"></a>01050 <span class="keywordflow">if</span>(has_dec_point) {
<a name="l01051"></a>01051 <span class="keywordflow">return</span> mk_real(sc,atof(q));
<a name="l01052"></a>01052 }
<a name="l01053"></a>01053 <span class="keywordflow">return</span> (mk_integer(sc, atol(q)));
<a name="l01054"></a>01054 }
<a name="l01055"></a>01055
<a name="l01056"></a>01056 <span class="comment">/* make constant */</span>
<a name="l01057"></a>01057 <span class="keyword">static</span> pointer mk_sharp_const(scheme *sc, <span class="keywordtype">char</span> *name) {
<a name="l01058"></a>01058 <span class="keywordtype">long</span> x;
<a name="l01059"></a>01059 <span class="keywordtype">char</span> tmp[256];
<a name="l01060"></a>01060
<a name="l01061"></a>01061 <span class="keywordflow">if</span> (!strcmp(name, <span class="stringliteral">"t"</span>))
<a name="l01062"></a>01062 <span class="keywordflow">return</span> (sc-&gt;T);
<a name="l01063"></a>01063 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (!strcmp(name, <span class="stringliteral">"f"</span>))
<a name="l01064"></a>01064 <span class="keywordflow">return</span> (sc-&gt;F);
<a name="l01065"></a>01065 <span class="keywordflow">else</span> <span class="keywordflow">if</span> (*name == <span class="charliteral">'o'</span>) {<span class="comment">/* #o (octal) */</span>
<a name="l01066"></a>01066 sprintf(tmp, <span class="stringliteral">"0%s"</span>, name+1);
<a name="l01067"></a>01067 sscanf(tmp, <span class="stringliteral">"%lo"</span>, &amp;x);
<a name="l01068"></a>01068 <span class="keywordflow">return</span> (mk_integer(sc, x));
<a name="l01069"></a>01069 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (*name == <span class="charliteral">'d'</span>) { <span class="comment">/* #d (decimal) */</span>
<a name="l01070"></a>01070 sscanf(name+1, <span class="stringliteral">"%ld"</span>, &amp;x);
<a name="l01071"></a>01071 <span class="keywordflow">return</span> (mk_integer(sc, x));
<a name="l01072"></a>01072 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (*name == <span class="charliteral">'x'</span>) { <span class="comment">/* #x (hex) */</span>
<a name="l01073"></a>01073 sprintf(tmp, <span class="stringliteral">"0x%s"</span>, name+1);
<a name="l01074"></a>01074 sscanf(tmp, <span class="stringliteral">"%lx"</span>, &amp;x);
<a name="l01075"></a>01075 <span class="keywordflow">return</span> (mk_integer(sc, x));
<a name="l01076"></a>01076 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (*name == <span class="charliteral">'b'</span>) { <span class="comment">/* #b (binary) */</span>
<a name="l01077"></a>01077 x = binary_decode(name+1);
<a name="l01078"></a>01078 <span class="keywordflow">return</span> (mk_integer(sc, x));
<a name="l01079"></a>01079 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (*name == <span class="charliteral">'\\'</span>) { <span class="comment">/* #\w (character) */</span>
<a name="l01080"></a>01080 <span class="keywordtype">int</span> c=0;
<a name="l01081"></a>01081 <span class="keywordflow">if</span>(stricmp(name+1,<span class="stringliteral">"space"</span>)==0) {
<a name="l01082"></a>01082 c=<span class="charliteral">' '</span>;
<a name="l01083"></a>01083 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(stricmp(name+1,<span class="stringliteral">"newline"</span>)==0) {
<a name="l01084"></a>01084 c=<span class="charliteral">'\n'</span>;
<a name="l01085"></a>01085 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(stricmp(name+1,<span class="stringliteral">"return"</span>)==0) {
<a name="l01086"></a>01086 c=<span class="charliteral">'\r'</span>;
<a name="l01087"></a>01087 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(stricmp(name+1,<span class="stringliteral">"tab"</span>)==0) {
<a name="l01088"></a>01088 c=<span class="charliteral">'\t'</span>;
<a name="l01089"></a>01089 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(name[1]==<span class="charliteral">'x'</span> &amp;&amp; name[2]!=0) {
<a name="l01090"></a>01090 <span class="keywordtype">int</span> c1=0;
<a name="l01091"></a>01091 <span class="keywordflow">if</span>(sscanf(name+2,<span class="stringliteral">"%x"</span>,&amp;c1)==1 &amp;&amp; c1&lt;256) {
<a name="l01092"></a>01092 c=c1;
<a name="l01093"></a>01093 } <span class="keywordflow">else</span> {
<a name="l01094"></a>01094 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l01095"></a>01095 }
<a name="l01096"></a>01096 <span class="preprocessor">#if USE_ASCII_NAMES</span>
<a name="l01097"></a>01097 <span class="preprocessor"></span> } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(is_ascii_name(name+1,&amp;c)) {
<a name="l01098"></a>01098 <span class="comment">/* nothing */</span>
<a name="l01099"></a>01099 <span class="preprocessor">#endif </span>
<a name="l01100"></a>01100 <span class="preprocessor"></span> } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(name[2]==0) {
<a name="l01101"></a>01101 c=name[1];
<a name="l01102"></a>01102 } <span class="keywordflow">else</span> {
<a name="l01103"></a>01103 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l01104"></a>01104 }
<a name="l01105"></a>01105 <span class="keywordflow">return</span> mk_character(sc,c);
<a name="l01106"></a>01106 } <span class="keywordflow">else</span>
<a name="l01107"></a>01107 <span class="keywordflow">return</span> (sc-&gt;NIL);
<a name="l01108"></a>01108 }
<a name="l01109"></a>01109
<a name="l01110"></a>01110 <span class="comment">/* ========== garbage collector ========== */</span>
<a name="l01111"></a>01111
<a name="l01112"></a>01112 <span class="comment">/*--</span>
<a name="l01113"></a>01113 <span class="comment"> * We use algorithm E (Knuth, The Art of Computer Programming Vol.1,</span>
<a name="l01114"></a>01114 <span class="comment"> * sec. 2.3.5), the Schorr-Deutsch-Waite link-inversion algorithm, </span>
<a name="l01115"></a>01115 <span class="comment"> * for marking. </span>
<a name="l01116"></a>01116 <span class="comment"> */</span>
<a name="l01117"></a>01117 <span class="keyword">static</span> <span class="keywordtype">void</span> mark(pointer a) {
<a name="l01118"></a>01118 pointer t, q, p;
<a name="l01119"></a>01119
<a name="l01120"></a>01120 t = (pointer) 0;
<a name="l01121"></a>01121 p = a;
<a name="l01122"></a>01122 E2: setmark(p);
<a name="l01123"></a>01123 <span class="keywordflow">if</span>(is_vector(p)) {
<a name="l01124"></a>01124 <span class="keywordtype">int</span> i;
<a name="l01125"></a>01125 <span class="keywordtype">int</span> num=ivalue_unchecked(p)/2+ivalue_unchecked(p)%2;
<a name="l01126"></a>01126 <span class="keywordflow">for</span>(i=0; i&lt;num; i++) {
<a name="l01127"></a>01127 <span class="comment">/* Vector cells will be treated like ordinary cells */</span>
<a name="l01128"></a>01128 mark(p+1+i);
<a name="l01129"></a>01129 }
<a name="l01130"></a>01130 }
<a name="l01131"></a>01131 <span class="keywordflow">if</span> (is_atom(p))
<a name="l01132"></a>01132 <span class="keywordflow">goto</span> E6;
<a name="l01133"></a>01133 <span class="comment">/* E4: down car */</span>
<a name="l01134"></a>01134 q = car(p);
<a name="l01135"></a>01135 <span class="keywordflow">if</span> (q &amp;&amp; !is_mark(q)) {
<a name="l01136"></a>01136 setatom(p); <span class="comment">/* a note that we have moved car */</span>
<a name="l01137"></a>01137 car(p) = t;
<a name="l01138"></a>01138 t = p;
<a name="l01139"></a>01139 p = q;
<a name="l01140"></a>01140 <span class="keywordflow">goto</span> E2;
<a name="l01141"></a>01141 }
<a name="l01142"></a>01142 E5: q = cdr(p); <span class="comment">/* down cdr */</span>
<a name="l01143"></a>01143 <span class="keywordflow">if</span> (q &amp;&amp; !is_mark(q)) {
<a name="l01144"></a>01144 cdr(p) = t;
<a name="l01145"></a>01145 t = p;
<a name="l01146"></a>01146 p = q;
<a name="l01147"></a>01147 <span class="keywordflow">goto</span> E2;
<a name="l01148"></a>01148 }
<a name="l01149"></a>01149 E6: <span class="comment">/* up. Undo the link switching from steps E4 and E5. */</span>
<a name="l01150"></a>01150 <span class="keywordflow">if</span> (!t)
<a name="l01151"></a>01151 <span class="keywordflow">return</span>;
<a name="l01152"></a>01152 q = t;
<a name="l01153"></a>01153 <span class="keywordflow">if</span> (is_atom(q)) {
<a name="l01154"></a>01154 clratom(q);
<a name="l01155"></a>01155 t = car(q);
<a name="l01156"></a>01156 car(q) = p;
<a name="l01157"></a>01157 p = q;
<a name="l01158"></a>01158 <span class="keywordflow">goto</span> E5;
<a name="l01159"></a>01159 } <span class="keywordflow">else</span> {
<a name="l01160"></a>01160 t = cdr(q);
<a name="l01161"></a>01161 cdr(q) = p;
<a name="l01162"></a>01162 p = q;
<a name="l01163"></a>01163 <span class="keywordflow">goto</span> E6;
<a name="l01164"></a>01164 }
<a name="l01165"></a>01165 }
<a name="l01166"></a>01166
<a name="l01167"></a>01167 <span class="comment">/* garbage collection. parameter a, b is marked. */</span>
<a name="l01168"></a>01168 <span class="keyword">static</span> <span class="keywordtype">void</span> gc(scheme *sc, pointer a, pointer b) {
<a name="l01169"></a>01169 pointer p;
<a name="l01170"></a>01170 <span class="keywordtype">int</span> i;
<a name="l01171"></a>01171
<a name="l01172"></a>01172 <span class="keywordflow">if</span>(sc-&gt;gc_verbose) {
<a name="l01173"></a>01173 putstr(sc, <span class="stringliteral">"gc..."</span>);
<a name="l01174"></a>01174 }
<a name="l01175"></a>01175
<a name="l01176"></a>01176 <span class="comment">/* mark system globals */</span>
<a name="l01177"></a>01177 mark(sc-&gt;oblist);
<a name="l01178"></a>01178 mark(sc-&gt;global_env);
<a name="l01179"></a>01179
<a name="l01180"></a>01180 <span class="comment">/* mark current registers */</span>
<a name="l01181"></a>01181 mark(sc-&gt;args);
<a name="l01182"></a>01182 mark(sc-&gt;envir);
<a name="l01183"></a>01183 mark(sc-&gt;code);
<a name="l01184"></a>01184 dump_stack_mark(sc);
<a name="l01185"></a>01185 mark(sc-&gt;value);
<a name="l01186"></a>01186 mark(sc-&gt;inport);
<a name="l01187"></a>01187 mark(sc-&gt;save_inport);
<a name="l01188"></a>01188 mark(sc-&gt;outport);
<a name="l01189"></a>01189 mark(sc-&gt;loadport);
<a name="l01190"></a>01190
<a name="l01191"></a>01191 <span class="comment">/* mark variables a, b */</span>
<a name="l01192"></a>01192 mark(a);
<a name="l01193"></a>01193 mark(b);
<a name="l01194"></a>01194
<a name="l01195"></a>01195 <span class="comment">/* garbage collect */</span>
<a name="l01196"></a>01196 clrmark(sc-&gt;NIL);
<a name="l01197"></a>01197 sc-&gt;fcells = 0;
<a name="l01198"></a>01198 sc-&gt;free_cell = sc-&gt;NIL;
<a name="l01199"></a>01199 <span class="comment">/* free-list is kept sorted by address so as to maintain consecutive</span>
<a name="l01200"></a>01200 <span class="comment"> ranges, if possible, for use with vectors. Here we scan the cells</span>
<a name="l01201"></a>01201 <span class="comment"> (which are also kept sorted by address) downwards to build the</span>
<a name="l01202"></a>01202 <span class="comment"> free-list in sorted order.</span>
<a name="l01203"></a>01203 <span class="comment"> */</span>
<a name="l01204"></a>01204 <span class="keywordflow">for</span> (i = sc-&gt;last_cell_seg; i &gt;= 0; i--) {
<a name="l01205"></a>01205 p = sc-&gt;cell_seg[i] + CELL_SEGSIZE;
<a name="l01206"></a>01206 <span class="keywordflow">while</span> (--p &gt;= sc-&gt;cell_seg[i]) {
<a name="l01207"></a>01207 <span class="keywordflow">if</span> (is_mark(p)) {
<a name="l01208"></a>01208 clrmark(p);
<a name="l01209"></a>01209 } <span class="keywordflow">else</span> {
<a name="l01210"></a>01210 <span class="comment">/* reclaim cell */</span>
<a name="l01211"></a>01211 <span class="keywordflow">if</span> (typeflag(p) != 0) {
<a name="l01212"></a>01212 finalize_cell(sc, p);
<a name="l01213"></a>01213 typeflag(p) = 0;
<a name="l01214"></a>01214 car(p) = sc-&gt;NIL;
<a name="l01215"></a>01215 }
<a name="l01216"></a>01216 ++sc-&gt;fcells;
<a name="l01217"></a>01217 cdr(p) = sc-&gt;free_cell;
<a name="l01218"></a>01218 sc-&gt;free_cell = p;
<a name="l01219"></a>01219 }
<a name="l01220"></a>01220 }
<a name="l01221"></a>01221 }
<a name="l01222"></a>01222
<a name="l01223"></a>01223 <span class="keywordflow">if</span> (sc-&gt;gc_verbose) {
<a name="l01224"></a>01224 <span class="keywordtype">char</span> msg[80];
<a name="l01225"></a>01225 sprintf(msg,<span class="stringliteral">"done: %ld cells were recovered.\n"</span>, sc-&gt;fcells);
<a name="l01226"></a>01226 putstr(sc,msg);
<a name="l01227"></a>01227 }
<a name="l01228"></a>01228 }
<a name="l01229"></a>01229
<a name="l01230"></a>01230 <span class="keyword">static</span> <span class="keywordtype">void</span> finalize_cell(scheme *sc, pointer a) {
<a name="l01231"></a>01231 <span class="keywordflow">if</span>(is_string(a)) {
<a name="l01232"></a>01232 sc-&gt;free(strvalue(a));
<a name="l01233"></a>01233 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(is_port(a)) {
<a name="l01234"></a>01234 <span class="keywordflow">if</span>(a-&gt;_object._port-&gt;kind&amp;port_file
<a name="l01235"></a>01235 &amp;&amp; a-&gt;_object._port-&gt;rep.stdio.closeit) {
<a name="l01236"></a>01236 port_close(sc,a,port_input|port_output);
<a name="l01237"></a>01237 }
<a name="l01238"></a>01238 sc-&gt;free(a-&gt;_object._port);
<a name="l01239"></a>01239 }
<a name="l01240"></a>01240 }
<a name="l01241"></a>01241
<a name="l01242"></a>01242 <span class="comment">/* ========== Routines for Reading ========== */</span>
<a name="l01243"></a>01243
<a name="l01244"></a>01244 <span class="keyword">static</span> <span class="keywordtype">int</span> file_push(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *fname) {
<a name="l01245"></a>01245 FILE *fin=fopen(fname,<span class="stringliteral">"r"</span>);
<a name="l01246"></a>01246 <span class="keywordflow">if</span>(fin!=0) {
<a name="l01247"></a>01247 sc-&gt;file_i++;
<a name="l01248"></a>01248 sc-&gt;load_stack[sc-&gt;file_i].kind=port_file|port_input;
<a name="l01249"></a>01249 sc-&gt;load_stack[sc-&gt;file_i].rep.stdio.file=fin;
<a name="l01250"></a>01250 sc-&gt;load_stack[sc-&gt;file_i].rep.stdio.closeit=1;
<a name="l01251"></a>01251 sc-&gt;nesting_stack[sc-&gt;file_i]=0;
<a name="l01252"></a>01252 sc-&gt;loadport-&gt;_object._port=sc-&gt;load_stack+sc-&gt;file_i;
<a name="l01253"></a>01253 }
<a name="l01254"></a>01254 <span class="keywordflow">return</span> fin!=0;
<a name="l01255"></a>01255 }
<a name="l01256"></a>01256
<a name="l01257"></a>01257 <span class="keyword">static</span> <span class="keywordtype">void</span> file_pop(scheme *sc) {
<a name="l01258"></a>01258 sc-&gt;nesting=sc-&gt;nesting_stack[sc-&gt;file_i];
<a name="l01259"></a>01259 <span class="keywordflow">if</span>(sc-&gt;file_i!=0) {
<a name="l01260"></a>01260 port_close(sc,sc-&gt;loadport,port_input);
<a name="l01261"></a>01261 sc-&gt;file_i--;
<a name="l01262"></a>01262 sc-&gt;loadport-&gt;_object._port=sc-&gt;load_stack+sc-&gt;file_i;
<a name="l01263"></a>01263 <span class="keywordflow">if</span>(file_interactive(sc)) {
<a name="l01264"></a>01264 putstr(sc,prompt);
<a name="l01265"></a>01265 }
<a name="l01266"></a>01266 }
<a name="l01267"></a>01267 }
<a name="l01268"></a>01268
<a name="l01269"></a>01269 <span class="keyword">static</span> <span class="keywordtype">int</span> file_interactive(scheme *sc) {
<a name="l01270"></a>01270 <span class="keywordflow">return</span> sc-&gt;file_i==0 &amp;&amp; sc-&gt;load_stack[0].rep.stdio.file==stdin
<a name="l01271"></a>01271 &amp;&amp; sc-&gt;inport-&gt;_object._port-&gt;kind&amp;port_file;
<a name="l01272"></a>01272 }
<a name="l01273"></a>01273
<a name="l01274"></a>01274 <span class="keyword">static</span> port *port_rep_from_filename(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *fn, <span class="keywordtype">int</span> prop) {
<a name="l01275"></a>01275 FILE *f;
<a name="l01276"></a>01276 <span class="keywordtype">char</span> *rw;
<a name="l01277"></a>01277 port *pt;
<a name="l01278"></a>01278 <span class="keywordflow">if</span>(prop==(port_input|port_output)) {
<a name="l01279"></a>01279 rw=<span class="stringliteral">"a+"</span>;
<a name="l01280"></a>01280 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(prop==port_output) {
<a name="l01281"></a>01281 rw=<span class="stringliteral">"w"</span>;
<a name="l01282"></a>01282 } <span class="keywordflow">else</span> {
<a name="l01283"></a>01283 rw=<span class="stringliteral">"r"</span>;
<a name="l01284"></a>01284 }
<a name="l01285"></a>01285 f=fopen(fn,rw);
<a name="l01286"></a>01286 <span class="keywordflow">if</span>(f==0) {
<a name="l01287"></a>01287 <span class="keywordflow">return</span> 0;
<a name="l01288"></a>01288 }
<a name="l01289"></a>01289 pt=port_rep_from_file(sc,f,prop);
<a name="l01290"></a>01290 pt-&gt;rep.stdio.closeit=1;
<a name="l01291"></a>01291 <span class="keywordflow">return</span> pt;
<a name="l01292"></a>01292 }
<a name="l01293"></a>01293
<a name="l01294"></a>01294 <span class="keyword">static</span> pointer port_from_filename(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *fn, <span class="keywordtype">int</span> prop) {
<a name="l01295"></a>01295 port *pt;
<a name="l01296"></a>01296 pt=port_rep_from_filename(sc,fn,prop);
<a name="l01297"></a>01297 <span class="keywordflow">if</span>(pt==0) {
<a name="l01298"></a>01298 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l01299"></a>01299 }
<a name="l01300"></a>01300 <span class="keywordflow">return</span> mk_port(sc,pt);
<a name="l01301"></a>01301 }
<a name="l01302"></a>01302
<a name="l01303"></a>01303 <span class="keyword">static</span> port *port_rep_from_file(scheme *sc, FILE *f, <span class="keywordtype">int</span> prop) {
<a name="l01304"></a>01304 <span class="keywordtype">char</span> *rw;
<a name="l01305"></a>01305 port *pt;
<a name="l01306"></a>01306 pt=(port*)sc-&gt;malloc(<span class="keyword">sizeof</span>(port));
<a name="l01307"></a>01307 <span class="keywordflow">if</span>(pt==0) {
<a name="l01308"></a>01308 <span class="keywordflow">return</span> 0;
<a name="l01309"></a>01309 }
<a name="l01310"></a>01310 <span class="keywordflow">if</span>(prop==(port_input|port_output)) {
<a name="l01311"></a>01311 rw=<span class="stringliteral">"a+"</span>;
<a name="l01312"></a>01312 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(prop==port_output) {
<a name="l01313"></a>01313 rw=<span class="stringliteral">"w"</span>;
<a name="l01314"></a>01314 } <span class="keywordflow">else</span> {
<a name="l01315"></a>01315 rw=<span class="stringliteral">"r"</span>;
<a name="l01316"></a>01316 }
<a name="l01317"></a>01317 pt-&gt;kind=port_file|prop;
<a name="l01318"></a>01318 pt-&gt;rep.stdio.file=f;
<a name="l01319"></a>01319 pt-&gt;rep.stdio.closeit=0;
<a name="l01320"></a>01320 <span class="keywordflow">return</span> pt;
<a name="l01321"></a>01321 }
<a name="l01322"></a>01322
<a name="l01323"></a>01323 <span class="keyword">static</span> pointer port_from_file(scheme *sc, FILE *f, <span class="keywordtype">int</span> prop) {
<a name="l01324"></a>01324 port *pt;
<a name="l01325"></a>01325 pt=port_rep_from_file(sc,f,prop);
<a name="l01326"></a>01326 <span class="keywordflow">if</span>(pt==0) {
<a name="l01327"></a>01327 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l01328"></a>01328 }
<a name="l01329"></a>01329 <span class="keywordflow">return</span> mk_port(sc,pt);
<a name="l01330"></a>01330 }
<a name="l01331"></a>01331
<a name="l01332"></a>01332 <span class="keyword">static</span> port *port_rep_from_string(scheme *sc, <span class="keywordtype">char</span> *start, <span class="keywordtype">char</span> *past_the_end, <span class="keywordtype">int</span> prop) {
<a name="l01333"></a>01333 port *pt;
<a name="l01334"></a>01334 pt=(port*)sc-&gt;malloc(<span class="keyword">sizeof</span>(port));
<a name="l01335"></a>01335 <span class="keywordflow">if</span>(pt==0) {
<a name="l01336"></a>01336 <span class="keywordflow">return</span> 0;
<a name="l01337"></a>01337 }
<a name="l01338"></a>01338 pt-&gt;kind=port_string|prop;
<a name="l01339"></a>01339 pt-&gt;rep.string.start=start;
<a name="l01340"></a>01340 pt-&gt;rep.string.curr=start;
<a name="l01341"></a>01341 pt-&gt;rep.string.past_the_end=past_the_end;
<a name="l01342"></a>01342 <span class="keywordflow">return</span> pt;
<a name="l01343"></a>01343 }
<a name="l01344"></a>01344
<a name="l01345"></a>01345 <span class="keyword">static</span> pointer port_from_string(scheme *sc, <span class="keywordtype">char</span> *start, <span class="keywordtype">char</span> *past_the_end, <span class="keywordtype">int</span> prop) {
<a name="l01346"></a>01346 port *pt;
<a name="l01347"></a>01347 pt=port_rep_from_string(sc,start,past_the_end,prop);
<a name="l01348"></a>01348 <span class="keywordflow">if</span>(pt==0) {
<a name="l01349"></a>01349 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l01350"></a>01350 }
<a name="l01351"></a>01351 <span class="keywordflow">return</span> mk_port(sc,pt);
<a name="l01352"></a>01352 }
<a name="l01353"></a>01353
<a name="l01354"></a>01354 <span class="keyword">static</span> <span class="keywordtype">void</span> port_close(scheme *sc, pointer p, <span class="keywordtype">int</span> flag) {
<a name="l01355"></a>01355 port *pt=p-&gt;_object._port;
<a name="l01356"></a>01356 pt-&gt;kind&amp;=~flag;
<a name="l01357"></a>01357 <span class="keywordflow">if</span>((pt-&gt;kind &amp; (port_input|port_output))==0) {
<a name="l01358"></a>01358 <span class="keywordflow">if</span>(pt-&gt;kind&amp;port_file) {
<a name="l01359"></a>01359 fclose(pt-&gt;rep.stdio.file);
<a name="l01360"></a>01360 }
<a name="l01361"></a>01361 pt-&gt;kind=port_free;
<a name="l01362"></a>01362 }
<a name="l01363"></a>01363 }
<a name="l01364"></a>01364
<a name="l01365"></a>01365 <span class="comment">/* get new character from input file */</span>
<a name="l01366"></a>01366 <span class="keyword">static</span> <span class="keywordtype">int</span> inchar(scheme *sc) {
<a name="l01367"></a>01367 <span class="keywordtype">int</span> c;
<a name="l01368"></a>01368 port *pt;
<a name="l01369"></a>01369 again:
<a name="l01370"></a>01370 pt=sc-&gt;inport-&gt;_object._port;
<a name="l01371"></a>01371 c=basic_inchar(pt);
<a name="l01372"></a>01372 <span class="keywordflow">if</span>(c==EOF &amp;&amp; sc-&gt;inport==sc-&gt;loadport &amp;&amp; sc-&gt;file_i!=0) {
<a name="l01373"></a>01373 file_pop(sc);
<a name="l01374"></a>01374 <span class="keywordflow">if</span>(sc-&gt;nesting!=0) {
<a name="l01375"></a>01375 <span class="keywordflow">return</span> EOF;
<a name="l01376"></a>01376 }
<a name="l01377"></a>01377 <span class="keywordflow">goto</span> again;
<a name="l01378"></a>01378 }
<a name="l01379"></a>01379 <span class="keywordflow">return</span> c;
<a name="l01380"></a>01380 }
<a name="l01381"></a>01381
<a name="l01382"></a>01382 <span class="keyword">static</span> <span class="keywordtype">int</span> basic_inchar(port *pt) {
<a name="l01383"></a>01383 <span class="keywordflow">if</span>(pt-&gt;kind&amp;port_file) {
<a name="l01384"></a>01384 <span class="keywordflow">return</span> fgetc(pt-&gt;rep.stdio.file);
<a name="l01385"></a>01385 } <span class="keywordflow">else</span> {
<a name="l01386"></a>01386 <span class="keywordflow">if</span>(*pt-&gt;rep.string.curr==0
<a name="l01387"></a>01387 || pt-&gt;rep.string.curr==pt-&gt;rep.string.past_the_end) {
<a name="l01388"></a>01388 <span class="keywordflow">return</span> EOF;
<a name="l01389"></a>01389 } <span class="keywordflow">else</span> {
<a name="l01390"></a>01390 <span class="keywordflow">return</span> *pt-&gt;rep.string.curr++;
<a name="l01391"></a>01391 }
<a name="l01392"></a>01392 }
<a name="l01393"></a>01393 }
<a name="l01394"></a>01394
<a name="l01395"></a>01395 <span class="comment">/* back character to input buffer */</span>
<a name="l01396"></a>01396 <span class="keyword">static</span> <span class="keywordtype">void</span> backchar(scheme *sc, <span class="keywordtype">int</span> c) {
<a name="l01397"></a>01397 port *pt;
<a name="l01398"></a>01398 <span class="keywordflow">if</span>(c==EOF) <span class="keywordflow">return</span>;
<a name="l01399"></a>01399 pt=sc-&gt;inport-&gt;_object._port;
<a name="l01400"></a>01400 <span class="keywordflow">if</span>(pt-&gt;kind&amp;port_file) {
<a name="l01401"></a>01401 ungetc(c,pt-&gt;rep.stdio.file);
<a name="l01402"></a>01402 } <span class="keywordflow">else</span> {
<a name="l01403"></a>01403 <span class="keywordflow">if</span>(pt-&gt;rep.string.curr!=pt-&gt;rep.string.start) {
<a name="l01404"></a>01404 --pt-&gt;rep.string.curr;
<a name="l01405"></a>01405 }
<a name="l01406"></a>01406 }
<a name="l01407"></a>01407 }
<a name="l01408"></a>01408
<a name="l01409"></a>01409 INTERFACE <span class="keywordtype">void</span> putstr(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *s) {
<a name="l01410"></a>01410 port *pt=sc-&gt;outport-&gt;_object._port;
<a name="l01411"></a>01411 <span class="keywordflow">if</span>(pt-&gt;kind&amp;port_file) {
<a name="l01412"></a>01412 fputs(s,pt-&gt;rep.stdio.file);
<a name="l01413"></a>01413 } <span class="keywordflow">else</span> {
<a name="l01414"></a>01414 <span class="keywordflow">for</span>(;*s;s++) {
<a name="l01415"></a>01415 <span class="keywordflow">if</span>(pt-&gt;rep.string.curr!=pt-&gt;rep.string.past_the_end) {
<a name="l01416"></a>01416 *pt-&gt;rep.string.curr++=*s;
<a name="l01417"></a>01417 }
<a name="l01418"></a>01418 }
<a name="l01419"></a>01419 }
<a name="l01420"></a>01420 }
<a name="l01421"></a>01421
<a name="l01422"></a>01422 <span class="keyword">static</span> <span class="keywordtype">void</span> putchars(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *s, <span class="keywordtype">int</span> len) {
<a name="l01423"></a>01423 port *pt=sc-&gt;outport-&gt;_object._port;
<a name="l01424"></a>01424 <span class="keywordflow">if</span>(pt-&gt;kind&amp;port_file) {
<a name="l01425"></a>01425 fwrite(s,1,len,pt-&gt;rep.stdio.file);
<a name="l01426"></a>01426 } <span class="keywordflow">else</span> {
<a name="l01427"></a>01427 <span class="keywordflow">for</span>(;len;len--) {
<a name="l01428"></a>01428 <span class="keywordflow">if</span>(pt-&gt;rep.string.curr!=pt-&gt;rep.string.past_the_end) {
<a name="l01429"></a>01429 *pt-&gt;rep.string.curr++=*s++;
<a name="l01430"></a>01430 }
<a name="l01431"></a>01431 }
<a name="l01432"></a>01432 }
<a name="l01433"></a>01433 }
<a name="l01434"></a>01434
<a name="l01435"></a>01435 INTERFACE <span class="keywordtype">void</span> putcharacter(scheme *sc, <span class="keywordtype">int</span> c) {
<a name="l01436"></a>01436 port *pt=sc-&gt;outport-&gt;_object._port;
<a name="l01437"></a>01437 <span class="keywordflow">if</span>(pt-&gt;kind&amp;port_file) {
<a name="l01438"></a>01438 fputc(c,pt-&gt;rep.stdio.file);
<a name="l01439"></a>01439 } <span class="keywordflow">else</span> {
<a name="l01440"></a>01440 <span class="keywordflow">if</span>(pt-&gt;rep.string.curr!=pt-&gt;rep.string.past_the_end) {
<a name="l01441"></a>01441 *pt-&gt;rep.string.curr++=c;
<a name="l01442"></a>01442 }
<a name="l01443"></a>01443 }
<a name="l01444"></a>01444 }
<a name="l01445"></a>01445
<a name="l01446"></a>01446 <span class="comment">/* read characters up to delimiter, but cater to character constants */</span>
<a name="l01447"></a>01447 <span class="keyword">static</span> <span class="keywordtype">char</span> *readstr_upto(scheme *sc, <span class="keywordtype">char</span> *delim) {
<a name="l01448"></a>01448 <span class="keywordtype">char</span> *p = sc-&gt;strbuff;
<a name="l01449"></a>01449
<a name="l01450"></a>01450 <span class="keywordflow">while</span> (!is_one_of(delim, (*p++ = inchar(sc))));
<a name="l01451"></a>01451 <span class="keywordflow">if</span>(p==sc-&gt;strbuff+2 &amp;&amp; p[-2]==<span class="charliteral">'\\'</span>) {
<a name="l01452"></a>01452 *p=0;
<a name="l01453"></a>01453 } <span class="keywordflow">else</span> {
<a name="l01454"></a>01454 backchar(sc,p[-1]);
<a name="l01455"></a>01455 *--p = <span class="charliteral">'\0'</span>;
<a name="l01456"></a>01456 }
<a name="l01457"></a>01457 <span class="keywordflow">return</span> sc-&gt;strbuff;
<a name="l01458"></a>01458 }
<a name="l01459"></a>01459
<a name="l01460"></a>01460 <span class="comment">/* read string expression "xxx...xxx" */</span>
<a name="l01461"></a>01461 <span class="keyword">static</span> pointer readstrexp(scheme *sc) {
<a name="l01462"></a>01462 <span class="keywordtype">char</span> *p = sc-&gt;strbuff;
<a name="l01463"></a>01463 <span class="keywordtype">int</span> c;
<a name="l01464"></a>01464 <span class="keywordtype">int</span> c1=0;
<a name="l01465"></a>01465 <span class="keyword">enum</span> { st_ok, st_bsl, st_x1, st_x2} state=st_ok;
<a name="l01466"></a>01466
<a name="l01467"></a>01467 <span class="keywordflow">for</span> (;;) {
<a name="l01468"></a>01468 c=inchar(sc);
<a name="l01469"></a>01469 <span class="keywordflow">if</span>(c==EOF || p-sc-&gt;strbuff&gt;<span class="keyword">sizeof</span>(sc-&gt;strbuff)-1) {
<a name="l01470"></a>01470 <span class="keywordflow">return</span> sc-&gt;F;
<a name="l01471"></a>01471 }
<a name="l01472"></a>01472 <span class="keywordflow">switch</span>(state) {
<a name="l01473"></a>01473 <span class="keywordflow">case</span> st_ok:
<a name="l01474"></a>01474 <span class="keywordflow">switch</span>(c) {
<a name="l01475"></a>01475 <span class="keywordflow">case</span> <span class="charliteral">'\\'</span>:
<a name="l01476"></a>01476 state=st_bsl;
<a name="l01477"></a>01477 <span class="keywordflow">break</span>;
<a name="l01478"></a>01478 <span class="keywordflow">case</span> <span class="charliteral">'"'</span>:
<a name="l01479"></a>01479 *p=0;
<a name="l01480"></a>01480 <span class="keywordflow">return</span> mk_counted_string(sc,sc-&gt;strbuff,p-sc-&gt;strbuff);
<a name="l01481"></a>01481 <span class="keywordflow">default</span>:
<a name="l01482"></a>01482 *p++=c;
<a name="l01483"></a>01483 <span class="keywordflow">break</span>;
<a name="l01484"></a>01484 }
<a name="l01485"></a>01485 <span class="keywordflow">break</span>;
<a name="l01486"></a>01486 <span class="keywordflow">case</span> st_bsl:
<a name="l01487"></a>01487 <span class="keywordflow">switch</span>(c) {
<a name="l01488"></a>01488 <span class="keywordflow">case</span> <span class="charliteral">'x'</span>:
<a name="l01489"></a>01489 <span class="keywordflow">case</span> <span class="charliteral">'X'</span>:
<a name="l01490"></a>01490 state=st_x1;
<a name="l01491"></a>01491 c1=0;
<a name="l01492"></a>01492 <span class="keywordflow">break</span>;
<a name="l01493"></a>01493 <span class="keywordflow">case</span> <span class="charliteral">'n'</span>:
<a name="l01494"></a>01494 *p++=<span class="charliteral">'\n'</span>;
<a name="l01495"></a>01495 state=st_ok;
<a name="l01496"></a>01496 <span class="keywordflow">break</span>;
<a name="l01497"></a>01497 <span class="keywordflow">case</span> <span class="charliteral">'t'</span>:
<a name="l01498"></a>01498 *p++=<span class="charliteral">'\t'</span>;
<a name="l01499"></a>01499 state=st_ok;
<a name="l01500"></a>01500 <span class="keywordflow">break</span>;
<a name="l01501"></a>01501 <span class="keywordflow">case</span> <span class="charliteral">'r'</span>:
<a name="l01502"></a>01502 *p++=<span class="charliteral">'\r'</span>;
<a name="l01503"></a>01503 state=st_ok;
<a name="l01504"></a>01504 <span class="keywordflow">break</span>;
<a name="l01505"></a>01505 <span class="keywordflow">case</span> <span class="charliteral">'"'</span>:
<a name="l01506"></a>01506 *p++=<span class="charliteral">'"'</span>;
<a name="l01507"></a>01507 state=st_ok;
<a name="l01508"></a>01508 <span class="keywordflow">break</span>;
<a name="l01509"></a>01509 <span class="keywordflow">default</span>:
<a name="l01510"></a>01510 *p++=c;
<a name="l01511"></a>01511 state=st_ok;
<a name="l01512"></a>01512 <span class="keywordflow">break</span>;
<a name="l01513"></a>01513 }
<a name="l01514"></a>01514 <span class="keywordflow">break</span>;
<a name="l01515"></a>01515 <span class="keywordflow">case</span> st_x1:
<a name="l01516"></a>01516 <span class="keywordflow">case</span> st_x2:
<a name="l01517"></a>01517 c=toupper(c);
<a name="l01518"></a>01518 <span class="keywordflow">if</span>(c&gt;=<span class="charliteral">'0'</span> &amp;&amp; c&lt;=<span class="charliteral">'F'</span>) {
<a name="l01519"></a>01519 <span class="keywordflow">if</span>(c&lt;=<span class="charliteral">'9'</span>) {
<a name="l01520"></a>01520 c1=(c1&lt;&lt;4)+c-<span class="charliteral">'0'</span>;
<a name="l01521"></a>01521 } <span class="keywordflow">else</span> {
<a name="l01522"></a>01522 c1=(c1&lt;&lt;4)+c-<span class="charliteral">'A'</span>+10;
<a name="l01523"></a>01523 }
<a name="l01524"></a>01524 <span class="keywordflow">if</span>(state==st_x1) {
<a name="l01525"></a>01525 state=st_x2;
<a name="l01526"></a>01526 } <span class="keywordflow">else</span> {
<a name="l01527"></a>01527 *p++=c1;
<a name="l01528"></a>01528 state=st_ok;
<a name="l01529"></a>01529 }
<a name="l01530"></a>01530 } <span class="keywordflow">else</span> {
<a name="l01531"></a>01531 <span class="keywordflow">return</span> sc-&gt;F;
<a name="l01532"></a>01532 }
<a name="l01533"></a>01533 <span class="keywordflow">break</span>;
<a name="l01534"></a>01534 }
<a name="l01535"></a>01535 }
<a name="l01536"></a>01536 }
<a name="l01537"></a>01537
<a name="l01538"></a>01538 <span class="comment">/* check c is in chars */</span>
<a name="l01539"></a>01539 <span class="keyword">static</span> INLINE <span class="keywordtype">int</span> is_one_of(<span class="keywordtype">char</span> *s, <span class="keywordtype">int</span> c) {
<a name="l01540"></a>01540 <span class="keywordflow">if</span>(c==EOF) <span class="keywordflow">return</span> 1;
<a name="l01541"></a>01541 <span class="keywordflow">while</span> (*s)
<a name="l01542"></a>01542 <span class="keywordflow">if</span> (*s++ == c)
<a name="l01543"></a>01543 <span class="keywordflow">return</span> (1);
<a name="l01544"></a>01544 <span class="keywordflow">return</span> (0);
<a name="l01545"></a>01545 }
<a name="l01546"></a>01546
<a name="l01547"></a>01547 <span class="comment">/* skip white characters */</span>
<a name="l01548"></a>01548 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> skipspace(scheme *sc) {
<a name="l01549"></a>01549 <span class="keywordtype">int</span> c;
<a name="l01550"></a>01550 <span class="keywordflow">while</span> (isspace(c=inchar(sc)))
<a name="l01551"></a>01551 ;
<a name="l01552"></a>01552 <span class="keywordflow">if</span>(c!=EOF) {
<a name="l01553"></a>01553 backchar(sc,c);
<a name="l01554"></a>01554 }
<a name="l01555"></a>01555 }
<a name="l01556"></a>01556
<a name="l01557"></a>01557 <span class="comment">/* get token */</span>
<a name="l01558"></a>01558 <span class="keyword">static</span> <span class="keywordtype">int</span> token(scheme *sc) {
<a name="l01559"></a>01559 <span class="keywordtype">int</span> c;
<a name="l01560"></a>01560 skipspace(sc);
<a name="l01561"></a>01561 <span class="keywordflow">switch</span> (c=inchar(sc)) {
<a name="l01562"></a>01562 <span class="keywordflow">case</span> EOF:
<a name="l01563"></a>01563 <span class="keywordflow">return</span> (TOK_EOF);
<a name="l01564"></a>01564 <span class="keywordflow">case</span> <span class="charliteral">'('</span>:
<a name="l01565"></a>01565 <span class="keywordflow">return</span> (TOK_LPAREN);
<a name="l01566"></a>01566 <span class="keywordflow">case</span> <span class="charliteral">')'</span>:
<a name="l01567"></a>01567 <span class="keywordflow">return</span> (TOK_RPAREN);
<a name="l01568"></a>01568 <span class="keywordflow">case</span> <span class="charliteral">'.'</span>:
<a name="l01569"></a>01569 c=inchar(sc);
<a name="l01570"></a>01570 <span class="keywordflow">if</span>(is_one_of(<span class="stringliteral">" \n\t"</span>,c)) {
<a name="l01571"></a>01571 <span class="keywordflow">return</span> (TOK_DOT);
<a name="l01572"></a>01572 } <span class="keywordflow">else</span> {
<a name="l01573"></a>01573 backchar(sc,c);
<a name="l01574"></a>01574 backchar(sc,<span class="charliteral">'.'</span>);
<a name="l01575"></a>01575 <span class="keywordflow">return</span> TOK_ATOM;
<a name="l01576"></a>01576 }
<a name="l01577"></a>01577 <span class="keywordflow">case</span> <span class="charliteral">'\''</span>:
<a name="l01578"></a>01578 <span class="keywordflow">return</span> (TOK_QUOTE);
<a name="l01579"></a>01579 <span class="keywordflow">case</span> <span class="charliteral">';'</span>:
<a name="l01580"></a>01580 <span class="keywordflow">return</span> (TOK_COMMENT);
<a name="l01581"></a>01581 <span class="keywordflow">case</span> <span class="charliteral">'"'</span>:
<a name="l01582"></a>01582 <span class="keywordflow">return</span> (TOK_DQUOTE);
<a name="l01583"></a>01583 <span class="keywordflow">case</span> BACKQUOTE:
<a name="l01584"></a>01584 <span class="keywordflow">return</span> (TOK_BQUOTE);
<a name="l01585"></a>01585 <span class="keywordflow">case</span> <span class="charliteral">','</span>:
<a name="l01586"></a>01586 <span class="keywordflow">if</span> ((c=inchar(sc)) == <span class="charliteral">'@'</span>)
<a name="l01587"></a>01587 <span class="keywordflow">return</span> (TOK_ATMARK);
<a name="l01588"></a>01588 <span class="keywordflow">else</span> {
<a name="l01589"></a>01589 backchar(sc,c);
<a name="l01590"></a>01590 <span class="keywordflow">return</span> (TOK_COMMA);
<a name="l01591"></a>01591 }
<a name="l01592"></a>01592 <span class="keywordflow">case</span> <span class="charliteral">'#'</span>:
<a name="l01593"></a>01593 c=inchar(sc);
<a name="l01594"></a>01594 <span class="keywordflow">if</span> (c == <span class="charliteral">'('</span>) {
<a name="l01595"></a>01595 <span class="keywordflow">return</span> (TOK_VEC);
<a name="l01596"></a>01596 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(c == <span class="charliteral">'!'</span>) {
<a name="l01597"></a>01597 <span class="keywordflow">return</span> TOK_COMMENT;
<a name="l01598"></a>01598 } <span class="keywordflow">else</span> {
<a name="l01599"></a>01599 backchar(sc,c);
<a name="l01600"></a>01600 <span class="keywordflow">if</span>(is_one_of(<span class="stringliteral">" tfodxb\\"</span>,c)) {
<a name="l01601"></a>01601 <span class="keywordflow">return</span> TOK_SHARP_CONST;
<a name="l01602"></a>01602 } <span class="keywordflow">else</span> {
<a name="l01603"></a>01603 <span class="keywordflow">return</span> (TOK_SHARP);
<a name="l01604"></a>01604 }
<a name="l01605"></a>01605 }
<a name="l01606"></a>01606 <span class="keywordflow">default</span>:
<a name="l01607"></a>01607 backchar(sc,c);
<a name="l01608"></a>01608 <span class="keywordflow">return</span> (TOK_ATOM);
<a name="l01609"></a>01609 }
<a name="l01610"></a>01610 }
<a name="l01611"></a>01611
<a name="l01612"></a>01612 <span class="comment">/* ========== Routines for Printing ========== */</span>
<a name="l01613"></a>01613 <span class="preprocessor">#define ok_abbrev(x) (is_pair(x) &amp;&amp; cdr(x) == sc-&gt;NIL)</span>
<a name="l01614"></a>01614 <span class="preprocessor"></span>
<a name="l01615"></a>01615 <span class="keyword">static</span> <span class="keywordtype">void</span> printslashstring(scheme *sc, <span class="keywordtype">char</span> *p, <span class="keywordtype">int</span> len) {
<a name="l01616"></a>01616 <span class="keywordtype">int</span> i;
<a name="l01617"></a>01617 <span class="keywordtype">unsigned</span> <span class="keywordtype">char</span> *s=(<span class="keywordtype">unsigned</span> <span class="keywordtype">char</span>*)p;
<a name="l01618"></a>01618 putcharacter(sc,<span class="charliteral">'"'</span>);
<a name="l01619"></a>01619 <span class="keywordflow">for</span> ( i=0; i&lt;len; i++) {
<a name="l01620"></a>01620 <span class="keywordflow">if</span>(*s==0xff || *s==<span class="charliteral">'"'</span> || *s&lt;<span class="charliteral">' '</span> || *s==<span class="charliteral">'\\'</span>) {
<a name="l01621"></a>01621 putcharacter(sc,<span class="charliteral">'\\'</span>);
<a name="l01622"></a>01622 <span class="keywordflow">switch</span>(*s) {
<a name="l01623"></a>01623 <span class="keywordflow">case</span> <span class="charliteral">'"'</span>:
<a name="l01624"></a>01624 putcharacter(sc,<span class="charliteral">'"'</span>);
<a name="l01625"></a>01625 <span class="keywordflow">break</span>;
<a name="l01626"></a>01626 <span class="keywordflow">case</span> <span class="charliteral">'\n'</span>:
<a name="l01627"></a>01627 putcharacter(sc,<span class="charliteral">'n'</span>);
<a name="l01628"></a>01628 <span class="keywordflow">break</span>;
<a name="l01629"></a>01629 <span class="keywordflow">case</span> <span class="charliteral">'\t'</span>:
<a name="l01630"></a>01630 putcharacter(sc,<span class="charliteral">'t'</span>);
<a name="l01631"></a>01631 <span class="keywordflow">break</span>;
<a name="l01632"></a>01632 <span class="keywordflow">case</span> <span class="charliteral">'\r'</span>:
<a name="l01633"></a>01633 putcharacter(sc,<span class="charliteral">'r'</span>);
<a name="l01634"></a>01634 <span class="keywordflow">break</span>;
<a name="l01635"></a>01635 <span class="keywordflow">case</span> <span class="charliteral">'\\'</span>:
<a name="l01636"></a>01636 putcharacter(sc,<span class="charliteral">'\\'</span>);
<a name="l01637"></a>01637 <span class="keywordflow">break</span>;
<a name="l01638"></a>01638 <span class="keywordflow">default</span>: {
<a name="l01639"></a>01639 <span class="keywordtype">int</span> d=*s/16;
<a name="l01640"></a>01640 putcharacter(sc,<span class="charliteral">'x'</span>);
<a name="l01641"></a>01641 <span class="keywordflow">if</span>(d&lt;10) {
<a name="l01642"></a>01642 putcharacter(sc,d+<span class="charliteral">'0'</span>);
<a name="l01643"></a>01643 } <span class="keywordflow">else</span> {
<a name="l01644"></a>01644 putcharacter(sc,d-10+<span class="charliteral">'A'</span>);
<a name="l01645"></a>01645 }
<a name="l01646"></a>01646 d=*s%16;
<a name="l01647"></a>01647 <span class="keywordflow">if</span>(d&lt;10) {
<a name="l01648"></a>01648 putcharacter(sc,d+<span class="charliteral">'0'</span>);
<a name="l01649"></a>01649 } <span class="keywordflow">else</span> {
<a name="l01650"></a>01650 putcharacter(sc,d-10+<span class="charliteral">'A'</span>);
<a name="l01651"></a>01651 }
<a name="l01652"></a>01652 }
<a name="l01653"></a>01653 }
<a name="l01654"></a>01654 } <span class="keywordflow">else</span> {
<a name="l01655"></a>01655 putcharacter(sc,*s);
<a name="l01656"></a>01656 }
<a name="l01657"></a>01657 s++;
<a name="l01658"></a>01658 }
<a name="l01659"></a>01659 putcharacter(sc,<span class="charliteral">'"'</span>);
<a name="l01660"></a>01660 }
<a name="l01661"></a>01661
<a name="l01662"></a>01662
<a name="l01663"></a>01663 <span class="comment">/* print atoms */</span>
<a name="l01664"></a>01664 <span class="keyword">static</span> <span class="keywordtype">void</span> printatom(scheme *sc, pointer l, <span class="keywordtype">int</span> f) {
<a name="l01665"></a>01665 <span class="keywordtype">char</span> *p;
<a name="l01666"></a>01666 <span class="keywordtype">int</span> len;
<a name="l01667"></a>01667 atom2str(sc,l,f,&amp;p,&amp;len);
<a name="l01668"></a>01668 putchars(sc,p,len);
<a name="l01669"></a>01669 }
<a name="l01670"></a>01670
<a name="l01671"></a>01671
<a name="l01672"></a>01672 <span class="comment">/* Uses internal buffer unless string pointer is already available */</span>
<a name="l01673"></a>01673 <span class="keyword">static</span> <span class="keywordtype">void</span> atom2str(scheme *sc, pointer l, <span class="keywordtype">int</span> f, <span class="keywordtype">char</span> **pp, <span class="keywordtype">int</span> *plen) {
<a name="l01674"></a>01674 <span class="keywordtype">char</span> *p;
<a name="l01675"></a>01675
<a name="l01676"></a>01676 <span class="keywordflow">if</span> (l == sc-&gt;NIL) {
<a name="l01677"></a>01677 p = <span class="stringliteral">"()"</span>;
<a name="l01678"></a>01678 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (l == sc-&gt;T) {
<a name="l01679"></a>01679 p = <span class="stringliteral">"#t"</span>;
<a name="l01680"></a>01680 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (l == sc-&gt;F) {
<a name="l01681"></a>01681 p = <span class="stringliteral">"#f"</span>;
<a name="l01682"></a>01682 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (l == sc-&gt;EOF_OBJ) {
<a name="l01683"></a>01683 p = <span class="stringliteral">"#&lt;EOF&gt;"</span>;
<a name="l01684"></a>01684 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_port(l)) {
<a name="l01685"></a>01685 p = sc-&gt;strbuff;
<a name="l01686"></a>01686 strcpy(p, <span class="stringliteral">"#&lt;PORT&gt;"</span>);
<a name="l01687"></a>01687 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_number(l)) {
<a name="l01688"></a>01688 p = sc-&gt;strbuff;
<a name="l01689"></a>01689 <span class="keywordflow">if</span>(is_integer(l)) {
<a name="l01690"></a>01690 sprintf(p, <span class="stringliteral">"%ld"</span>, ivalue_unchecked(l));
<a name="l01691"></a>01691 } <span class="keywordflow">else</span> {
<a name="l01692"></a>01692 sprintf(p, <span class="stringliteral">"%.10g"</span>, rvalue_unchecked(l));
<a name="l01693"></a>01693 }
<a name="l01694"></a>01694 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_string(l)) {
<a name="l01695"></a>01695 <span class="keywordflow">if</span> (!f) {
<a name="l01696"></a>01696 p = strvalue(l);
<a name="l01697"></a>01697 } <span class="keywordflow">else</span> { <span class="comment">/* Hack, uses the fact that printing is needed */</span>
<a name="l01698"></a>01698 *pp=sc-&gt;strbuff;
<a name="l01699"></a>01699 *plen=0;
<a name="l01700"></a>01700 printslashstring(sc, strvalue(l), strlength(l));
<a name="l01701"></a>01701 <span class="keywordflow">return</span>;
<a name="l01702"></a>01702 }
<a name="l01703"></a>01703 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_character(l)) {
<a name="l01704"></a>01704 <span class="keywordtype">int</span> c=charvalue(l);
<a name="l01705"></a>01705 p = sc-&gt;strbuff;
<a name="l01706"></a>01706 <span class="keywordflow">if</span> (!f) {
<a name="l01707"></a>01707 p[0]=c;
<a name="l01708"></a>01708 p[1]=0;
<a name="l01709"></a>01709 } <span class="keywordflow">else</span> {
<a name="l01710"></a>01710 <span class="keywordflow">switch</span>(c) {
<a name="l01711"></a>01711 <span class="keywordflow">case</span> <span class="charliteral">' '</span>:
<a name="l01712"></a>01712 sprintf(p,<span class="stringliteral">"#\\space"</span>); <span class="keywordflow">break</span>;
<a name="l01713"></a>01713 <span class="keywordflow">case</span> <span class="charliteral">'\n'</span>:
<a name="l01714"></a>01714 sprintf(p,<span class="stringliteral">"#\\newline"</span>); <span class="keywordflow">break</span>;
<a name="l01715"></a>01715 <span class="keywordflow">case</span> <span class="charliteral">'\r'</span>:
<a name="l01716"></a>01716 sprintf(p,<span class="stringliteral">"#\\return"</span>); <span class="keywordflow">break</span>;
<a name="l01717"></a>01717 <span class="keywordflow">case</span> <span class="charliteral">'\t'</span>:
<a name="l01718"></a>01718 sprintf(p,<span class="stringliteral">"#\\tab"</span>); <span class="keywordflow">break</span>;
<a name="l01719"></a>01719 <span class="keywordflow">default</span>:
<a name="l01720"></a>01720 <span class="preprocessor">#if USE_ASCII_NAMES</span>
<a name="l01721"></a>01721 <span class="preprocessor"></span> <span class="keywordflow">if</span>(c==127) {
<a name="l01722"></a>01722 strcpy(p,<span class="stringliteral">"#\\del"</span>); <span class="keywordflow">break</span>;
<a name="l01723"></a>01723 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(c&lt;32) {
<a name="l01724"></a>01724 strcpy(p,<span class="stringliteral">"#\\"</span>); strcat(p,charnames[c]); <span class="keywordflow">break</span>;
<a name="l01725"></a>01725 }
<a name="l01726"></a>01726 <span class="preprocessor">#else</span>
<a name="l01727"></a>01727 <span class="preprocessor"></span> <span class="keywordflow">if</span>(c&lt;32) {
<a name="l01728"></a>01728 sprintf(p,<span class="stringliteral">"#\\x%x"</span>,c); <span class="keywordflow">break</span>;
<a name="l01729"></a>01729 }
<a name="l01730"></a>01730 <span class="preprocessor">#endif</span>
<a name="l01731"></a>01731 <span class="preprocessor"></span> sprintf(p,<span class="stringliteral">"#\\%c"</span>,c); <span class="keywordflow">break</span>;
<a name="l01732"></a>01732 }
<a name="l01733"></a>01733 }
<a name="l01734"></a>01734 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_symbol(l)) {
<a name="l01735"></a>01735 p = symname(l);
<a name="l01736"></a>01736 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_proc(l)) {
<a name="l01737"></a>01737 p = sc-&gt;strbuff;
<a name="l01738"></a>01738 sprintf(p, <span class="stringliteral">"#&lt;%s PROCEDURE %ld&gt;"</span>, procname(l),procnum(l));
<a name="l01739"></a>01739 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_macro(l)) {
<a name="l01740"></a>01740 p = <span class="stringliteral">"#&lt;MACRO&gt;"</span>;
<a name="l01741"></a>01741 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_closure(l)) {
<a name="l01742"></a>01742 p = <span class="stringliteral">"#&lt;CLOSURE&gt;"</span>;
<a name="l01743"></a>01743 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_promise(l)) {
<a name="l01744"></a>01744 p = <span class="stringliteral">"#&lt;PROMISE&gt;"</span>;
<a name="l01745"></a>01745 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_foreign(l)) {
<a name="l01746"></a>01746 p = sc-&gt;strbuff;
<a name="l01747"></a>01747 sprintf(p, <span class="stringliteral">"#&lt;FOREIGN PROCEDURE %ld&gt;"</span>, procnum(l));
<a name="l01748"></a>01748 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_continuation(l)) {
<a name="l01749"></a>01749 p = <span class="stringliteral">"#&lt;CONTINUATION&gt;"</span>;
<a name="l01750"></a>01750 } <span class="keywordflow">else</span> {
<a name="l01751"></a>01751 p = <span class="stringliteral">"#&lt;ERROR&gt;"</span>;
<a name="l01752"></a>01752 }
<a name="l01753"></a>01753 *pp=p;
<a name="l01754"></a>01754 *plen=strlen(p);
<a name="l01755"></a>01755 }
<a name="l01756"></a>01756 <span class="comment">/* ========== Routines for Evaluation Cycle ========== */</span>
<a name="l01757"></a>01757
<a name="l01758"></a>01758 <span class="comment">/* make closure. c is code. e is environment */</span>
<a name="l01759"></a>01759 <span class="keyword">static</span> pointer mk_closure(scheme *sc, pointer c, pointer e) {
<a name="l01760"></a>01760 pointer x = get_cell(sc, c, e);
<a name="l01761"></a>01761
<a name="l01762"></a>01762 typeflag(x) = T_CLOSURE;
<a name="l01763"></a>01763 car(x) = c;
<a name="l01764"></a>01764 cdr(x) = e;
<a name="l01765"></a>01765 <span class="keywordflow">return</span> (x);
<a name="l01766"></a>01766 }
<a name="l01767"></a>01767
<a name="l01768"></a>01768 <span class="comment">/* make continuation. */</span>
<a name="l01769"></a>01769 <span class="keyword">static</span> pointer mk_continuation(scheme *sc, pointer d) {
<a name="l01770"></a>01770 pointer x = get_cell(sc, sc-&gt;NIL, d);
<a name="l01771"></a>01771
<a name="l01772"></a>01772 typeflag(x) = T_CONTINUATION;
<a name="l01773"></a>01773 cont_dump(x) = d;
<a name="l01774"></a>01774 <span class="keywordflow">return</span> (x);
<a name="l01775"></a>01775 }
<a name="l01776"></a>01776
<a name="l01777"></a>01777 <span class="keyword">static</span> pointer list_star(scheme *sc, pointer d) {
<a name="l01778"></a>01778 pointer p, q;
<a name="l01779"></a>01779 <span class="keywordflow">if</span>(cdr(d)==sc-&gt;NIL) {
<a name="l01780"></a>01780 <span class="keywordflow">return</span> car(d);
<a name="l01781"></a>01781 }
<a name="l01782"></a>01782 p=cons(sc,car(d),cdr(d));
<a name="l01783"></a>01783 q=p;
<a name="l01784"></a>01784 <span class="keywordflow">while</span>(cdr(cdr(p))!=sc-&gt;NIL) {
<a name="l01785"></a>01785 d=cons(sc,car(p),cdr(p));
<a name="l01786"></a>01786 <span class="keywordflow">if</span>(cdr(cdr(p))!=sc-&gt;NIL) {
<a name="l01787"></a>01787 p=cdr(d);
<a name="l01788"></a>01788 }
<a name="l01789"></a>01789 }
<a name="l01790"></a>01790 cdr(p)=car(cdr(p));
<a name="l01791"></a>01791 <span class="keywordflow">return</span> q;
<a name="l01792"></a>01792 }
<a name="l01793"></a>01793
<a name="l01794"></a>01794 <span class="comment">/* reverse list -- produce new list */</span>
<a name="l01795"></a>01795 <span class="keyword">static</span> pointer reverse(scheme *sc, pointer a) {
<a name="l01796"></a>01796 <span class="comment">/* a must be checked by gc */</span>
<a name="l01797"></a>01797 pointer p = sc-&gt;NIL;
<a name="l01798"></a>01798
<a name="l01799"></a>01799 <span class="keywordflow">for</span> ( ; is_pair(a); a = cdr(a)) {
<a name="l01800"></a>01800 p = cons(sc, car(a), p);
<a name="l01801"></a>01801 }
<a name="l01802"></a>01802 <span class="keywordflow">return</span> (p);
<a name="l01803"></a>01803 }
<a name="l01804"></a>01804
<a name="l01805"></a>01805 <span class="comment">/* reverse list --- in-place */</span>
<a name="l01806"></a>01806 <span class="keyword">static</span> pointer reverse_in_place(scheme *sc, pointer term, pointer list) {
<a name="l01807"></a>01807 pointer p = list, result = term, q;
<a name="l01808"></a>01808
<a name="l01809"></a>01809 <span class="keywordflow">while</span> (p != sc-&gt;NIL) {
<a name="l01810"></a>01810 q = cdr(p);
<a name="l01811"></a>01811 cdr(p) = result;
<a name="l01812"></a>01812 result = p;
<a name="l01813"></a>01813 p = q;
<a name="l01814"></a>01814 }
<a name="l01815"></a>01815 <span class="keywordflow">return</span> (result);
<a name="l01816"></a>01816 }
<a name="l01817"></a>01817
<a name="l01818"></a>01818 <span class="comment">/* append list -- produce new list */</span>
<a name="l01819"></a>01819 <span class="keyword">static</span> pointer append(scheme *sc, pointer a, pointer b) {
<a name="l01820"></a>01820 pointer p = b, q;
<a name="l01821"></a>01821
<a name="l01822"></a>01822 <span class="keywordflow">if</span> (a != sc-&gt;NIL) {
<a name="l01823"></a>01823 a = reverse(sc, a);
<a name="l01824"></a>01824 <span class="keywordflow">while</span> (a != sc-&gt;NIL) {
<a name="l01825"></a>01825 q = cdr(a);
<a name="l01826"></a>01826 cdr(a) = p;
<a name="l01827"></a>01827 p = a;
<a name="l01828"></a>01828 a = q;
<a name="l01829"></a>01829 }
<a name="l01830"></a>01830 }
<a name="l01831"></a>01831 <span class="keywordflow">return</span> (p);
<a name="l01832"></a>01832 }
<a name="l01833"></a>01833
<a name="l01834"></a>01834 <span class="comment">/* equivalence of atoms */</span>
<a name="l01835"></a>01835 <span class="keyword">static</span> <span class="keywordtype">int</span> eqv(pointer a, pointer b) {
<a name="l01836"></a>01836 <span class="keywordflow">if</span> (is_string(a)) {
<a name="l01837"></a>01837 <span class="keywordflow">if</span> (is_string(b))
<a name="l01838"></a>01838 <span class="keywordflow">return</span> (strvalue(a) == strvalue(b));
<a name="l01839"></a>01839 <span class="keywordflow">else</span>
<a name="l01840"></a>01840 <span class="keywordflow">return</span> (0);
<a name="l01841"></a>01841 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_number(a)) {
<a name="l01842"></a>01842 <span class="keywordflow">if</span> (is_number(b))
<a name="l01843"></a>01843 <span class="keywordflow">return</span> num_eq(nvalue(a),nvalue(b));
<a name="l01844"></a>01844 <span class="keywordflow">else</span>
<a name="l01845"></a>01845 <span class="keywordflow">return</span> (0);
<a name="l01846"></a>01846 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_character(a)) {
<a name="l01847"></a>01847 <span class="keywordflow">if</span> (is_character(b))
<a name="l01848"></a>01848 <span class="keywordflow">return</span> charvalue(a)==charvalue(b);
<a name="l01849"></a>01849 <span class="keywordflow">else</span>
<a name="l01850"></a>01850 <span class="keywordflow">return</span> (0);
<a name="l01851"></a>01851 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_port(a)) {
<a name="l01852"></a>01852 <span class="keywordflow">if</span> (is_port(b))
<a name="l01853"></a>01853 <span class="keywordflow">return</span> a==b;
<a name="l01854"></a>01854 <span class="keywordflow">else</span>
<a name="l01855"></a>01855 <span class="keywordflow">return</span> (0);
<a name="l01856"></a>01856 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_proc(a)) {
<a name="l01857"></a>01857 <span class="keywordflow">if</span> (is_proc(b))
<a name="l01858"></a>01858 <span class="keywordflow">return</span> procnum(a)==procnum(b);
<a name="l01859"></a>01859 <span class="keywordflow">else</span>
<a name="l01860"></a>01860 <span class="keywordflow">return</span> (0);
<a name="l01861"></a>01861 } <span class="keywordflow">else</span> {
<a name="l01862"></a>01862 <span class="keywordflow">return</span> (a == b);
<a name="l01863"></a>01863 }
<a name="l01864"></a>01864 }
<a name="l01865"></a>01865
<a name="l01866"></a>01866 <span class="comment">/* true or false value macro */</span>
<a name="l01867"></a>01867 <span class="comment">/* () is #t in R5RS */</span>
<a name="l01868"></a>01868 <span class="preprocessor">#define is_true(p) ((p) != sc-&gt;F)</span>
<a name="l01869"></a>01869 <span class="preprocessor"></span><span class="preprocessor">#define is_false(p) ((p) == sc-&gt;F)</span>
<a name="l01870"></a>01870 <span class="preprocessor"></span>
<a name="l01871"></a>01871 <span class="comment">/* ========== Environment implementation ========== */</span>
<a name="l01872"></a>01872
<a name="l01873"></a>01873 <span class="preprocessor">#if !defined(USE_ALIST_ENV) || !defined(USE_OBJECT_LIST) </span>
<a name="l01874"></a>01874 <span class="preprocessor"></span>
<a name="l01875"></a>01875 <span class="keyword">static</span> <span class="keywordtype">int</span> hash_fn(<span class="keyword">const</span> <span class="keywordtype">char</span> *key, <span class="keywordtype">int</span> table_size)
<a name="l01876"></a>01876 {
<a name="l01877"></a>01877 <span class="keywordtype">unsigned</span> <span class="keywordtype">int</span> hashed = 0;
<a name="l01878"></a>01878 <span class="keyword">const</span> <span class="keywordtype">char</span> *c;
<a name="l01879"></a>01879 <span class="keywordtype">int</span> bits_per_int = <span class="keyword">sizeof</span>(<span class="keywordtype">unsigned</span> int)*8;
<a name="l01880"></a>01880
<a name="l01881"></a>01881 <span class="keywordflow">for</span> (c = key; *c; c++) {
<a name="l01882"></a>01882 <span class="comment">/* letters have about 5 bits in them */</span>
<a name="l01883"></a>01883 hashed = (hashed&lt;&lt;5) | (hashed&gt;&gt;(bits_per_int-5));
<a name="l01884"></a>01884 hashed ^= *c;
<a name="l01885"></a>01885 }
<a name="l01886"></a>01886 <span class="keywordflow">return</span> hashed % table_size;
<a name="l01887"></a>01887 }
<a name="l01888"></a>01888 <span class="preprocessor">#endif </span>
<a name="l01889"></a>01889 <span class="preprocessor"></span>
<a name="l01890"></a>01890 <span class="preprocessor">#ifndef USE_ALIST_ENV </span>
<a name="l01891"></a>01891 <span class="preprocessor"></span>
<a name="l01892"></a>01892 <span class="comment">/* </span>
<a name="l01893"></a>01893 <span class="comment"> * In this implementation, each frame of the environment may be </span>
<a name="l01894"></a>01894 <span class="comment"> * a hash table: a vector of alists hashed by variable name. </span>
<a name="l01895"></a>01895 <span class="comment"> * In practice, we use a vector only for the initial frame; </span>
<a name="l01896"></a>01896 <span class="comment"> * subsequent frames are too small and transient for the lookup </span>
<a name="l01897"></a>01897 <span class="comment"> * speed to out-weigh the cost of making a new vector. </span>
<a name="l01898"></a>01898 <span class="comment"> */</span>
<a name="l01899"></a>01899
<a name="l01900"></a>01900 <span class="keyword">static</span> <span class="keywordtype">void</span> new_frame_in_env(scheme *sc, pointer old_env)
<a name="l01901"></a>01901 {
<a name="l01902"></a>01902 pointer new_frame;
<a name="l01903"></a>01903
<a name="l01904"></a>01904 <span class="comment">/* The interaction-environment has about 300 variables in it. */</span>
<a name="l01905"></a>01905 <span class="keywordflow">if</span> (old_env == sc-&gt;NIL) {
<a name="l01906"></a>01906 new_frame = mk_vector(sc, 461);
<a name="l01907"></a>01907 } <span class="keywordflow">else</span> {
<a name="l01908"></a>01908 new_frame = sc-&gt;NIL;
<a name="l01909"></a>01909 }
<a name="l01910"></a>01910
<a name="l01911"></a>01911 sc-&gt;envir = immutable_cons(sc, new_frame, old_env);
<a name="l01912"></a>01912 setenvironment(sc-&gt;envir);
<a name="l01913"></a>01913 }
<a name="l01914"></a>01914
<a name="l01915"></a>01915 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> new_slot_spec_in_env(scheme *sc, pointer env,
<a name="l01916"></a>01916 pointer variable, pointer value)
<a name="l01917"></a>01917 {
<a name="l01918"></a>01918 pointer slot = immutable_cons(sc, variable, value);
<a name="l01919"></a>01919
<a name="l01920"></a>01920 <span class="keywordflow">if</span> (is_vector(car(env))) {
<a name="l01921"></a>01921 <span class="keywordtype">int</span> location = hash_fn(symname(variable), ivalue_unchecked(car(env)));
<a name="l01922"></a>01922
<a name="l01923"></a>01923 set_vector_elem(car(env), location,
<a name="l01924"></a>01924 immutable_cons(sc, slot, vector_elem(car(env), location)));
<a name="l01925"></a>01925 } <span class="keywordflow">else</span> {
<a name="l01926"></a>01926 car(env) = immutable_cons(sc, slot, car(env));
<a name="l01927"></a>01927 }
<a name="l01928"></a>01928 }
<a name="l01929"></a>01929
<a name="l01930"></a>01930 <span class="keyword">static</span> pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, <span class="keywordtype">int</span> all)
<a name="l01931"></a>01931 {
<a name="l01932"></a>01932 pointer x = sc-&gt;NIL, y = sc-&gt;NIL;
<a name="l01933"></a>01933 <span class="keywordtype">int</span> location = 0;
<a name="l01934"></a>01934
<a name="l01935"></a>01935 <span class="keywordflow">for</span> (x = env; x != sc-&gt;NIL; x = cdr(x)) {
<a name="l01936"></a>01936 <span class="keywordflow">if</span> (is_vector(car(x))) {
<a name="l01937"></a>01937 location = hash_fn(symname(hdl), ivalue_unchecked(car(x)));
<a name="l01938"></a>01938 y = vector_elem(car(x), location);
<a name="l01939"></a>01939 } <span class="keywordflow">else</span> {
<a name="l01940"></a>01940 y = car(x);
<a name="l01941"></a>01941 }
<a name="l01942"></a>01942 <span class="keywordflow">for</span> ( ; y != sc-&gt;NIL; y = cdr(y)) {
<a name="l01943"></a>01943 <span class="keywordflow">if</span> (caar(y) == hdl) {
<a name="l01944"></a>01944 <span class="keywordflow">break</span>;
<a name="l01945"></a>01945 }
<a name="l01946"></a>01946 }
<a name="l01947"></a>01947 <span class="keywordflow">if</span> (y != sc-&gt;NIL) {
<a name="l01948"></a>01948 <span class="keywordflow">break</span>;
<a name="l01949"></a>01949 }
<a name="l01950"></a>01950 <span class="keywordflow">if</span>(!all) {
<a name="l01951"></a>01951 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l01952"></a>01952 }
<a name="l01953"></a>01953 }
<a name="l01954"></a>01954 <span class="keywordflow">if</span> (x != sc-&gt;NIL) {
<a name="l01955"></a>01955 <span class="keywordflow">return</span> car(y);
<a name="l01956"></a>01956 }
<a name="l01957"></a>01957 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l01958"></a>01958 }
<a name="l01959"></a>01959
<a name="l01960"></a>01960 <span class="preprocessor">#else </span><span class="comment">/* USE_ALIST_ENV */</span>
<a name="l01961"></a>01961
<a name="l01962"></a>01962 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> new_frame_in_env(scheme *sc, pointer old_env)
<a name="l01963"></a>01963 {
<a name="l01964"></a>01964 sc-&gt;envir = immutable_cons(sc, sc-&gt;NIL, old_env);
<a name="l01965"></a>01965 setenvironment(sc-&gt;envir);
<a name="l01966"></a>01966 }
<a name="l01967"></a>01967
<a name="l01968"></a>01968 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> new_slot_spec_in_env(scheme *sc, pointer env,
<a name="l01969"></a>01969 pointer variable, pointer value)
<a name="l01970"></a>01970 {
<a name="l01971"></a>01971 car(env) = immutable_cons(sc, immutable_cons(sc, variable, value), car(env));
<a name="l01972"></a>01972 }
<a name="l01973"></a>01973
<a name="l01974"></a>01974 <span class="keyword">static</span> pointer find_slot_in_env(scheme *sc, pointer env, pointer hdl, <span class="keywordtype">int</span> all)
<a name="l01975"></a>01975 {
<a name="l01976"></a>01976 pointer x,y;
<a name="l01977"></a>01977 <span class="keywordflow">for</span> (x = env; x != sc-&gt;NIL; x = cdr(x)) {
<a name="l01978"></a>01978 <span class="keywordflow">for</span> (y = car(x); y != sc-&gt;NIL; y = cdr(y)) {
<a name="l01979"></a>01979 <span class="keywordflow">if</span> (caar(y) == hdl) {
<a name="l01980"></a>01980 <span class="keywordflow">break</span>;
<a name="l01981"></a>01981 }
<a name="l01982"></a>01982 }
<a name="l01983"></a>01983 <span class="keywordflow">if</span> (y != sc-&gt;NIL) {
<a name="l01984"></a>01984 <span class="keywordflow">break</span>;
<a name="l01985"></a>01985 }
<a name="l01986"></a>01986 <span class="keywordflow">if</span>(!all) {
<a name="l01987"></a>01987 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l01988"></a>01988 }
<a name="l01989"></a>01989 }
<a name="l01990"></a>01990 <span class="keywordflow">if</span> (x != sc-&gt;NIL) {
<a name="l01991"></a>01991 <span class="keywordflow">return</span> car(y);
<a name="l01992"></a>01992 }
<a name="l01993"></a>01993 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l01994"></a>01994 }
<a name="l01995"></a>01995
<a name="l01996"></a>01996 <span class="preprocessor">#endif </span><span class="comment">/* USE_ALIST_ENV else */</span>
<a name="l01997"></a>01997
<a name="l01998"></a>01998 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> new_slot_in_env(scheme *sc, pointer variable, pointer value)
<a name="l01999"></a>01999 {
<a name="l02000"></a>02000 new_slot_spec_in_env(sc, sc-&gt;envir, variable, value);
<a name="l02001"></a>02001 }
<a name="l02002"></a>02002
<a name="l02003"></a>02003 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> set_slot_in_env(scheme *sc, pointer slot, pointer value)
<a name="l02004"></a>02004 {
<a name="l02005"></a>02005 cdr(slot) = value;
<a name="l02006"></a>02006 }
<a name="l02007"></a>02007
<a name="l02008"></a>02008 <span class="keyword">static</span> INLINE pointer slot_value_in_env(pointer slot)
<a name="l02009"></a>02009 {
<a name="l02010"></a>02010 <span class="keywordflow">return</span> cdr(slot);
<a name="l02011"></a>02011 }
<a name="l02012"></a>02012
<a name="l02013"></a>02013 <span class="comment">/* ========== Evaluation Cycle ========== */</span>
<a name="l02014"></a>02014
<a name="l02015"></a>02015
<a name="l02016"></a>02016 <span class="keyword">static</span> pointer _Error_1(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *s, pointer a) {
<a name="l02017"></a>02017 <span class="preprocessor">#if USE_ERROR_HOOK</span>
<a name="l02018"></a>02018 <span class="preprocessor"></span> pointer x;
<a name="l02019"></a>02019 pointer hdl=sc-&gt;ERROR_HOOK;
<a name="l02020"></a>02020
<a name="l02021"></a>02021 x=find_slot_in_env(sc,sc-&gt;envir,hdl,1);
<a name="l02022"></a>02022 <span class="keywordflow">if</span> (x != sc-&gt;NIL) {
<a name="l02023"></a>02023 <span class="keywordflow">if</span>(a!=0) {
<a name="l02024"></a>02024 sc-&gt;code = cons(sc, cons(sc, sc-&gt;QUOTE, cons(sc,(a), sc-&gt;NIL)), sc-&gt;NIL);
<a name="l02025"></a>02025 } <span class="keywordflow">else</span> {
<a name="l02026"></a>02026 sc-&gt;code = sc-&gt;NIL;
<a name="l02027"></a>02027 }
<a name="l02028"></a>02028 sc-&gt;code = cons(sc, mk_string(sc, (s)), sc-&gt;code);
<a name="l02029"></a>02029 setimmutable(car(sc-&gt;code));
<a name="l02030"></a>02030 sc-&gt;code = cons(sc, slot_value_in_env(x), sc-&gt;code);
<a name="l02031"></a>02031 sc-&gt;op = (int)OP_EVAL;
<a name="l02032"></a>02032 <span class="keywordflow">return</span> sc-&gt;T;
<a name="l02033"></a>02033 }
<a name="l02034"></a>02034 <span class="preprocessor">#endif</span>
<a name="l02035"></a>02035 <span class="preprocessor"></span>
<a name="l02036"></a>02036 <span class="keywordflow">if</span>(a!=0) {
<a name="l02037"></a>02037 sc-&gt;args = cons(sc, (a), sc-&gt;NIL);
<a name="l02038"></a>02038 } <span class="keywordflow">else</span> {
<a name="l02039"></a>02039 sc-&gt;args = sc-&gt;NIL;
<a name="l02040"></a>02040 }
<a name="l02041"></a>02041 sc-&gt;args = cons(sc, mk_string(sc, (s)), sc-&gt;args);
<a name="l02042"></a>02042 setimmutable(car(sc-&gt;args));
<a name="l02043"></a>02043 sc-&gt;op = (int)OP_ERR0;
<a name="l02044"></a>02044 <span class="keywordflow">return</span> sc-&gt;T;
<a name="l02045"></a>02045 }
<a name="l02046"></a>02046 <span class="preprocessor">#define Error_1(sc,s, a) return _Error_1(sc,s,a)</span>
<a name="l02047"></a>02047 <span class="preprocessor"></span><span class="preprocessor">#define Error_0(sc,s) return _Error_1(sc,s,0)</span>
<a name="l02048"></a>02048 <span class="preprocessor"></span>
<a name="l02049"></a>02049 <span class="comment">/* Too small to turn into function */</span>
<a name="l02050"></a>02050 <span class="preprocessor"># define BEGIN do {</span>
<a name="l02051"></a>02051 <span class="preprocessor"></span><span class="preprocessor"># define END } while (0)</span>
<a name="l02052"></a>02052 <span class="preprocessor"></span><span class="preprocessor">#define s_goto(sc,a) BEGIN \</span>
<a name="l02053"></a>02053 <span class="preprocessor"> sc-&gt;op = (int)(a); \</span>
<a name="l02054"></a>02054 <span class="preprocessor"> return sc-&gt;T; END</span>
<a name="l02055"></a>02055 <span class="preprocessor"></span>
<a name="l02056"></a>02056 <span class="preprocessor">#define s_return(sc,a) return _s_return(sc,a) </span>
<a name="l02057"></a>02057 <span class="preprocessor"></span>
<a name="l02058"></a>02058 <span class="preprocessor">#ifndef USE_SCHEME_STACK </span>
<a name="l02059"></a>02059 <span class="preprocessor"></span>
<a name="l02060"></a>02060 <span class="comment">/* this structure holds all the interpreter's registers */</span>
<a name="l02061"></a>02061 <span class="keyword">struct </span>dump_stack_frame {
<a name="l02062"></a>02062 <span class="keyword">enum</span> scheme_opcodes op;
<a name="l02063"></a>02063 pointer args;
<a name="l02064"></a>02064 pointer envir;
<a name="l02065"></a>02065 pointer code;
<a name="l02066"></a>02066 };
<a name="l02067"></a>02067
<a name="l02068"></a>02068 <span class="preprocessor">#define STACK_GROWTH 3 </span>
<a name="l02069"></a>02069 <span class="preprocessor"></span>
<a name="l02070"></a>02070 <span class="keyword">static</span> <span class="keywordtype">void</span> s_save(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op, pointer args, pointer code)
<a name="l02071"></a>02071 {
<a name="l02072"></a>02072 <span class="keywordtype">long</span> nframes = (long)sc-&gt;dump;
<a name="l02073"></a>02073 <span class="keyword">struct</span> dump_stack_frame *next_frame;
<a name="l02074"></a>02074
<a name="l02075"></a>02075 <span class="comment">/* enough room for the next frame? */</span>
<a name="l02076"></a>02076 if (nframes &gt;= sc-&gt;dump_size) {
<a name="l02077"></a>02077 sc-&gt;dump_size += STACK_GROWTH;
<a name="l02078"></a>02078 <span class="comment">/* alas there is no sc-&gt;realloc */</span>
<a name="l02079"></a>02079 sc-&gt;dump_base = realloc(sc-&gt;dump_base,
<a name="l02080"></a>02080 <span class="keyword">sizeof</span>(<span class="keyword">struct</span> dump_stack_frame) * sc-&gt;dump_size);
<a name="l02081"></a>02081 }
<a name="l02082"></a>02082 next_frame = (<span class="keyword">struct </span>dump_stack_frame *)sc-&gt;dump_base + nframes;
<a name="l02083"></a>02083 next_frame-&gt;op = op;
<a name="l02084"></a>02084 next_frame-&gt;args = args;
<a name="l02085"></a>02085 next_frame-&gt;envir = sc-&gt;envir;
<a name="l02086"></a>02086 next_frame-&gt;code = code;
<a name="l02087"></a>02087 sc-&gt;dump = (pointer)(nframes+1L);
<a name="l02088"></a>02088 }
<a name="l02089"></a>02089
<a name="l02090"></a>02090 <span class="keyword">static</span> pointer _s_return(scheme *sc, pointer a)
<a name="l02091"></a>02091 {
<a name="l02092"></a>02092 <span class="keywordtype">long</span> nframes = (long)sc-&gt;dump;
<a name="l02093"></a>02093 <span class="keyword">struct</span> dump_stack_frame *frame;
<a name="l02094"></a>02094
<a name="l02095"></a>02095 sc-&gt;value = (a);
<a name="l02096"></a>02096 <span class="keywordflow">if</span> (nframes &lt;= 0) {
<a name="l02097"></a>02097 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l02098"></a>02098 }
<a name="l02099"></a>02099 nframes--;
<a name="l02100"></a>02100 frame = (<span class="keyword">struct </span>dump_stack_frame *)sc-&gt;dump_base + nframes;
<a name="l02101"></a>02101 sc-&gt;op = frame-&gt;op;
<a name="l02102"></a>02102 sc-&gt;args = frame-&gt;args;
<a name="l02103"></a>02103 sc-&gt;envir = frame-&gt;envir;
<a name="l02104"></a>02104 sc-&gt;code = frame-&gt;code;
<a name="l02105"></a>02105 sc-&gt;dump = (pointer)nframes;
<a name="l02106"></a>02106 <span class="keywordflow">return</span> sc-&gt;T;
<a name="l02107"></a>02107 }
<a name="l02108"></a>02108
<a name="l02109"></a>02109 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> dump_stack_reset(scheme *sc)
<a name="l02110"></a>02110 {
<a name="l02111"></a>02111 <span class="comment">/* in this implementation, sc-&gt;dump is the number of frames on the stack */</span>
<a name="l02112"></a>02112 sc-&gt;dump = (pointer)0;
<a name="l02113"></a>02113 }
<a name="l02114"></a>02114
<a name="l02115"></a>02115 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> dump_stack_initialize(scheme *sc)
<a name="l02116"></a>02116 {
<a name="l02117"></a>02117 sc-&gt;dump_size = 0;
<a name="l02118"></a>02118 sc-&gt;dump_base = NULL;
<a name="l02119"></a>02119 dump_stack_reset(sc);
<a name="l02120"></a>02120 }
<a name="l02121"></a>02121
<a name="l02122"></a>02122 <span class="keyword">static</span> <span class="keywordtype">void</span> dump_stack_free(scheme *sc)
<a name="l02123"></a>02123 {
<a name="l02124"></a>02124 free(sc-&gt;dump_base);
<a name="l02125"></a>02125 sc-&gt;dump_base = NULL;
<a name="l02126"></a>02126 sc-&gt;dump = (pointer)0;
<a name="l02127"></a>02127 sc-&gt;dump_size = 0;
<a name="l02128"></a>02128 }
<a name="l02129"></a>02129
<a name="l02130"></a>02130 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> dump_stack_mark(scheme *sc)
<a name="l02131"></a>02131 {
<a name="l02132"></a>02132 <span class="keywordtype">long</span> nframes = (long)sc-&gt;dump;
<a name="l02133"></a>02133 <span class="keywordtype">int</span> i;
<a name="l02134"></a>02134 <span class="keywordflow">for</span>(i=0; i&lt;nframes; i++) {
<a name="l02135"></a>02135 <span class="keyword">struct </span>dump_stack_frame *frame;
<a name="l02136"></a>02136 frame = (<span class="keyword">struct </span>dump_stack_frame *)sc-&gt;dump_base + i;
<a name="l02137"></a>02137 mark(frame-&gt;args);
<a name="l02138"></a>02138 mark(frame-&gt;envir);
<a name="l02139"></a>02139 mark(frame-&gt;code);
<a name="l02140"></a>02140 }
<a name="l02141"></a>02141 }
<a name="l02142"></a>02142
<a name="l02143"></a>02143 <span class="preprocessor">#else </span>
<a name="l02144"></a>02144 <span class="preprocessor"></span>
<a name="l02145"></a>02145 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> dump_stack_reset(scheme *sc)
<a name="l02146"></a>02146 {
<a name="l02147"></a>02147 sc-&gt;dump = sc-&gt;NIL;
<a name="l02148"></a>02148 }
<a name="l02149"></a>02149
<a name="l02150"></a>02150 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> dump_stack_initialize(scheme *sc)
<a name="l02151"></a>02151 {
<a name="l02152"></a>02152 dump_stack_reset(sc);
<a name="l02153"></a>02153 }
<a name="l02154"></a>02154
<a name="l02155"></a>02155 <span class="keyword">static</span> <span class="keywordtype">void</span> dump_stack_free(scheme *sc)
<a name="l02156"></a>02156 {
<a name="l02157"></a>02157 sc-&gt;dump = sc-&gt;NIL;
<a name="l02158"></a>02158 }
<a name="l02159"></a>02159
<a name="l02160"></a>02160 <span class="keyword">static</span> pointer _s_return(scheme *sc, pointer a) {
<a name="l02161"></a>02161 sc-&gt;value = (a);
<a name="l02162"></a>02162 <span class="keywordflow">if</span>(sc-&gt;dump==sc-&gt;NIL) <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l02163"></a>02163 sc-&gt;op = ivalue(car(sc-&gt;dump));
<a name="l02164"></a>02164 sc-&gt;args = cadr(sc-&gt;dump);
<a name="l02165"></a>02165 sc-&gt;envir = caddr(sc-&gt;dump);
<a name="l02166"></a>02166 sc-&gt;code = cadddr(sc-&gt;dump);
<a name="l02167"></a>02167 sc-&gt;dump = cddddr(sc-&gt;dump);
<a name="l02168"></a>02168 <span class="keywordflow">return</span> sc-&gt;T;
<a name="l02169"></a>02169 }
<a name="l02170"></a>02170
<a name="l02171"></a>02171 <span class="keyword">static</span> <span class="keywordtype">void</span> s_save(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op, pointer args, pointer code) {
<a name="l02172"></a>02172 sc-&gt;dump = cons(sc, sc-&gt;envir, cons(sc, (code), sc-&gt;dump));
<a name="l02173"></a>02173 sc-&gt;dump = cons(sc, (args), sc-&gt;dump);
<a name="l02174"></a>02174 sc-&gt;dump = cons(sc, mk_integer(sc, (<span class="keywordtype">long</span>)(op)), sc-&gt;dump);
<a name="l02175"></a>02175 }
<a name="l02176"></a>02176
<a name="l02177"></a>02177 <span class="keyword">static</span> INLINE <span class="keywordtype">void</span> dump_stack_mark(scheme *sc)
<a name="l02178"></a>02178 {
<a name="l02179"></a>02179 mark(sc-&gt;dump);
<a name="l02180"></a>02180 }
<a name="l02181"></a>02181 <span class="preprocessor">#endif </span>
<a name="l02182"></a>02182 <span class="preprocessor"></span>
<a name="l02183"></a>02183 <span class="preprocessor">#define s_retbool(tf) s_return(sc,(tf) ? sc-&gt;T : sc-&gt;F)</span>
<a name="l02184"></a>02184 <span class="preprocessor"></span>
<a name="l02185"></a>02185 <span class="keyword">static</span> pointer opexe_0(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op) {
<a name="l02186"></a>02186 pointer x, y;
<a name="l02187"></a>02187
<a name="l02188"></a>02188 <span class="keywordflow">switch</span> (op) {
<a name="l02189"></a>02189 <span class="keywordflow">case</span> OP_LOAD: <span class="comment">/* load */</span>
<a name="l02190"></a>02190 <span class="keywordflow">if</span>(file_interactive(sc)) {
<a name="l02191"></a>02191 fprintf(sc-&gt;outport-&gt;_object._port-&gt;rep.stdio.file,
<a name="l02192"></a>02192 <span class="stringliteral">"Loading %s\n"</span>, strvalue(car(sc-&gt;args)));
<a name="l02193"></a>02193 }
<a name="l02194"></a>02194 <span class="keywordflow">if</span> (!file_push(sc,strvalue(car(sc-&gt;args)))) {
<a name="l02195"></a>02195 Error_1(sc,<span class="stringliteral">"unable to open"</span>, car(sc-&gt;args));
<a name="l02196"></a>02196 }
<a name="l02197"></a>02197 s_goto(sc,OP_T0LVL);
<a name="l02198"></a>02198
<a name="l02199"></a>02199 <span class="keywordflow">case</span> OP_T0LVL: <span class="comment">/* top level */</span>
<a name="l02200"></a>02200 <span class="keywordflow">if</span>(file_interactive(sc)) {
<a name="l02201"></a>02201 putstr(sc,<span class="stringliteral">"\n"</span>);
<a name="l02202"></a>02202 }
<a name="l02203"></a>02203 sc-&gt;nesting=0;
<a name="l02204"></a>02204 dump_stack_reset(sc);
<a name="l02205"></a>02205 sc-&gt;envir = sc-&gt;global_env;
<a name="l02206"></a>02206 sc-&gt;save_inport=sc-&gt;inport;
<a name="l02207"></a>02207 sc-&gt;inport = sc-&gt;loadport;
<a name="l02208"></a>02208 s_save(sc,OP_T0LVL, sc-&gt;NIL, sc-&gt;NIL);
<a name="l02209"></a>02209 s_save(sc,OP_VALUEPRINT, sc-&gt;NIL, sc-&gt;NIL);
<a name="l02210"></a>02210 s_save(sc,OP_T1LVL, sc-&gt;NIL, sc-&gt;NIL);
<a name="l02211"></a>02211 <span class="keywordflow">if</span> (file_interactive(sc)) {
<a name="l02212"></a>02212 putstr(sc,prompt);
<a name="l02213"></a>02213 }
<a name="l02214"></a>02214 s_goto(sc,OP_READ_INTERNAL);
<a name="l02215"></a>02215
<a name="l02216"></a>02216 <span class="keywordflow">case</span> OP_T1LVL: <span class="comment">/* top level */</span>
<a name="l02217"></a>02217 sc-&gt;code = sc-&gt;value;
<a name="l02218"></a>02218 sc-&gt;inport=sc-&gt;save_inport;
<a name="l02219"></a>02219 s_goto(sc,OP_EVAL);
<a name="l02220"></a>02220
<a name="l02221"></a>02221 <span class="keywordflow">case</span> OP_READ_INTERNAL: <span class="comment">/* internal read */</span>
<a name="l02222"></a>02222 sc-&gt;tok = token(sc);
<a name="l02223"></a>02223 <span class="keywordflow">if</span>(sc-&gt;tok==TOK_EOF) {
<a name="l02224"></a>02224 <span class="keywordflow">if</span>(sc-&gt;inport==sc-&gt;loadport) {
<a name="l02225"></a>02225 sc-&gt;args=sc-&gt;NIL;
<a name="l02226"></a>02226 s_goto(sc,OP_QUIT);
<a name="l02227"></a>02227 } <span class="keywordflow">else</span> {
<a name="l02228"></a>02228 s_return(sc,sc-&gt;EOF_OBJ);
<a name="l02229"></a>02229 }
<a name="l02230"></a>02230 }
<a name="l02231"></a>02231 s_goto(sc,OP_RDSEXPR);
<a name="l02232"></a>02232
<a name="l02233"></a>02233 <span class="keywordflow">case</span> OP_GENSYM:
<a name="l02234"></a>02234 s_return(sc, gensym(sc));
<a name="l02235"></a>02235
<a name="l02236"></a>02236 <span class="keywordflow">case</span> OP_VALUEPRINT: <span class="comment">/* print evaluation result */</span>
<a name="l02237"></a>02237 <span class="comment">/* OP_VALUEPRINT is always pushed, because when changing from</span>
<a name="l02238"></a>02238 <span class="comment"> non-interactive to interactive mode, it needs to be</span>
<a name="l02239"></a>02239 <span class="comment"> already on the stack */</span>
<a name="l02240"></a>02240 <span class="keywordflow">if</span>(sc-&gt;tracing) {
<a name="l02241"></a>02241 putstr(sc,<span class="stringliteral">"\nGives: "</span>);
<a name="l02242"></a>02242 }
<a name="l02243"></a>02243 <span class="keywordflow">if</span>(file_interactive(sc)) {
<a name="l02244"></a>02244 sc-&gt;print_flag = 1;
<a name="l02245"></a>02245 sc-&gt;args = sc-&gt;value;
<a name="l02246"></a>02246 s_goto(sc,OP_P0LIST);
<a name="l02247"></a>02247 } <span class="keywordflow">else</span> {
<a name="l02248"></a>02248 s_return(sc,sc-&gt;value);
<a name="l02249"></a>02249 }
<a name="l02250"></a>02250
<a name="l02251"></a>02251 <span class="keywordflow">case</span> OP_EVAL: <span class="comment">/* main part of evaluation */</span>
<a name="l02252"></a>02252 <span class="preprocessor">#if USE_TRACING</span>
<a name="l02253"></a>02253 <span class="preprocessor"></span> <span class="keywordflow">if</span>(sc-&gt;tracing) {
<a name="l02254"></a>02254 <span class="comment">/*s_save(sc,OP_VALUEPRINT,sc-&gt;NIL,sc-&gt;NIL);*/</span>
<a name="l02255"></a>02255 s_save(sc,OP_REAL_EVAL,sc-&gt;args,sc-&gt;code);
<a name="l02256"></a>02256 sc-&gt;args=sc-&gt;code;
<a name="l02257"></a>02257 putstr(sc,<span class="stringliteral">"\nEval: "</span>);
<a name="l02258"></a>02258 s_goto(sc,OP_P0LIST);
<a name="l02259"></a>02259 }
<a name="l02260"></a>02260 <span class="comment">/* fall through */</span>
<a name="l02261"></a>02261 <span class="keywordflow">case</span> OP_REAL_EVAL:
<a name="l02262"></a>02262 <span class="preprocessor">#endif</span>
<a name="l02263"></a>02263 <span class="preprocessor"></span> <span class="keywordflow">if</span> (is_symbol(sc-&gt;code)) { <span class="comment">/* symbol */</span>
<a name="l02264"></a>02264 x=find_slot_in_env(sc,sc-&gt;envir,sc-&gt;code,1);
<a name="l02265"></a>02265 <span class="keywordflow">if</span> (x != sc-&gt;NIL) {
<a name="l02266"></a>02266 s_return(sc,slot_value_in_env(x));
<a name="l02267"></a>02267 } <span class="keywordflow">else</span> {
<a name="l02268"></a>02268 Error_1(sc,<span class="stringliteral">"eval: unbound variable:"</span>, sc-&gt;code);
<a name="l02269"></a>02269 }
<a name="l02270"></a>02270 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_pair(sc-&gt;code)) {
<a name="l02271"></a>02271 <span class="keywordflow">if</span> (is_syntax(x = car(sc-&gt;code))) { <span class="comment">/* SYNTAX */</span>
<a name="l02272"></a>02272 sc-&gt;code = cdr(sc-&gt;code);
<a name="l02273"></a>02273 s_goto(sc,syntaxnum(x));
<a name="l02274"></a>02274 } <span class="keywordflow">else</span> {<span class="comment">/* first, eval top element and eval arguments */</span>
<a name="l02275"></a>02275 s_save(sc,OP_E0ARGS, sc-&gt;NIL, sc-&gt;code);
<a name="l02276"></a>02276 <span class="comment">/* If no macros =&gt; s_save(sc,OP_E1ARGS, sc-&gt;NIL, cdr(sc-&gt;code));*/</span>
<a name="l02277"></a>02277 sc-&gt;code = car(sc-&gt;code);
<a name="l02278"></a>02278 s_goto(sc,OP_EVAL);
<a name="l02279"></a>02279 }
<a name="l02280"></a>02280 } <span class="keywordflow">else</span> {
<a name="l02281"></a>02281 s_return(sc,sc-&gt;code);
<a name="l02282"></a>02282 }
<a name="l02283"></a>02283
<a name="l02284"></a>02284 <span class="keywordflow">case</span> OP_E0ARGS: <span class="comment">/* eval arguments */</span>
<a name="l02285"></a>02285 <span class="keywordflow">if</span> (is_macro(sc-&gt;value)) { <span class="comment">/* macro expansion */</span>
<a name="l02286"></a>02286 s_save(sc,OP_DOMACRO, sc-&gt;NIL, sc-&gt;NIL);
<a name="l02287"></a>02287 sc-&gt;args = cons(sc,sc-&gt;code, sc-&gt;NIL);
<a name="l02288"></a>02288 sc-&gt;code = sc-&gt;value;
<a name="l02289"></a>02289 s_goto(sc,OP_APPLY);
<a name="l02290"></a>02290 } <span class="keywordflow">else</span> {
<a name="l02291"></a>02291 sc-&gt;code = cdr(sc-&gt;code);
<a name="l02292"></a>02292 s_goto(sc,OP_E1ARGS);
<a name="l02293"></a>02293 }
<a name="l02294"></a>02294
<a name="l02295"></a>02295 <span class="keywordflow">case</span> OP_E1ARGS: <span class="comment">/* eval arguments */</span>
<a name="l02296"></a>02296 sc-&gt;args = cons(sc, sc-&gt;value, sc-&gt;args);
<a name="l02297"></a>02297 <span class="keywordflow">if</span> (is_pair(sc-&gt;code)) { <span class="comment">/* continue */</span>
<a name="l02298"></a>02298 s_save(sc,OP_E1ARGS, sc-&gt;args, cdr(sc-&gt;code));
<a name="l02299"></a>02299 sc-&gt;code = car(sc-&gt;code);
<a name="l02300"></a>02300 sc-&gt;args = sc-&gt;NIL;
<a name="l02301"></a>02301 s_goto(sc,OP_EVAL);
<a name="l02302"></a>02302 } <span class="keywordflow">else</span> { <span class="comment">/* end */</span>
<a name="l02303"></a>02303 sc-&gt;args = reverse_in_place(sc, sc-&gt;NIL, sc-&gt;args);
<a name="l02304"></a>02304 sc-&gt;code = car(sc-&gt;args);
<a name="l02305"></a>02305 sc-&gt;args = cdr(sc-&gt;args);
<a name="l02306"></a>02306 s_goto(sc,OP_APPLY);
<a name="l02307"></a>02307 }
<a name="l02308"></a>02308
<a name="l02309"></a>02309 <span class="preprocessor">#if USE_TRACING</span>
<a name="l02310"></a>02310 <span class="preprocessor"></span> <span class="keywordflow">case</span> OP_TRACING: {
<a name="l02311"></a>02311 <span class="keywordtype">int</span> tr=sc-&gt;tracing;
<a name="l02312"></a>02312 sc-&gt;tracing=ivalue(car(sc-&gt;args));
<a name="l02313"></a>02313 s_return(sc,mk_integer(sc,tr));
<a name="l02314"></a>02314 }
<a name="l02315"></a>02315 <span class="preprocessor">#endif</span>
<a name="l02316"></a>02316 <span class="preprocessor"></span>
<a name="l02317"></a>02317 <span class="keywordflow">case</span> OP_APPLY: <span class="comment">/* apply 'code' to 'args' */</span>
<a name="l02318"></a>02318 <span class="preprocessor">#if USE_TRACING</span>
<a name="l02319"></a>02319 <span class="preprocessor"></span> <span class="keywordflow">if</span>(sc-&gt;tracing) {
<a name="l02320"></a>02320 s_save(sc,OP_REAL_APPLY,sc-&gt;args,sc-&gt;code);
<a name="l02321"></a>02321 sc-&gt;print_flag = 1;
<a name="l02322"></a>02322 <span class="comment">/* sc-&gt;args=cons(sc,sc-&gt;code,sc-&gt;args);*/</span>
<a name="l02323"></a>02323 putstr(sc,<span class="stringliteral">"\nApply to: "</span>);
<a name="l02324"></a>02324 s_goto(sc,OP_P0LIST);
<a name="l02325"></a>02325 }
<a name="l02326"></a>02326 <span class="comment">/* fall through */</span>
<a name="l02327"></a>02327 <span class="keywordflow">case</span> OP_REAL_APPLY:
<a name="l02328"></a>02328 <span class="preprocessor">#endif</span>
<a name="l02329"></a>02329 <span class="preprocessor"></span> <span class="keywordflow">if</span> (is_proc(sc-&gt;code)) {
<a name="l02330"></a>02330 s_goto(sc,procnum(sc-&gt;code)); <span class="comment">/* PROCEDURE */</span>
<a name="l02331"></a>02331 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_foreign(sc-&gt;code)) {
<a name="l02332"></a>02332 x=sc-&gt;code-&gt;_object._ff(sc,sc-&gt;args);
<a name="l02333"></a>02333 s_return(sc,x);
<a name="l02334"></a>02334 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_closure(sc-&gt;code) || is_macro(sc-&gt;code)
<a name="l02335"></a>02335 || is_promise(sc-&gt;code)) { <span class="comment">/* CLOSURE */</span>
<a name="l02336"></a>02336 <span class="comment">/* Should not accept promise */</span>
<a name="l02337"></a>02337 <span class="comment">/* make environment */</span>
<a name="l02338"></a>02338 new_frame_in_env(sc, closure_env(sc-&gt;code));
<a name="l02339"></a>02339 <span class="keywordflow">for</span> (x = car(closure_code(sc-&gt;code)), y = sc-&gt;args;
<a name="l02340"></a>02340 is_pair(x); x = cdr(x), y = cdr(y)) {
<a name="l02341"></a>02341 <span class="keywordflow">if</span> (y == sc-&gt;NIL) {
<a name="l02342"></a>02342 Error_0(sc,<span class="stringliteral">"not enough arguments"</span>);
<a name="l02343"></a>02343 } <span class="keywordflow">else</span> {
<a name="l02344"></a>02344 new_slot_in_env(sc, car(x), car(y));
<a name="l02345"></a>02345 }
<a name="l02346"></a>02346 }
<a name="l02347"></a>02347 <span class="keywordflow">if</span> (x == sc-&gt;NIL) {
<a name="l02348"></a>02348 <span class="comment">/*--</span>
<a name="l02349"></a>02349 <span class="comment"> * if (y != sc-&gt;NIL) {</span>
<a name="l02350"></a>02350 <span class="comment"> * Error_0(sc,"too many arguments");</span>
<a name="l02351"></a>02351 <span class="comment"> * }</span>
<a name="l02352"></a>02352 <span class="comment"> */</span>
<a name="l02353"></a>02353 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_symbol(x))
<a name="l02354"></a>02354 new_slot_in_env(sc, x, y);
<a name="l02355"></a>02355 <span class="keywordflow">else</span> {
<a name="l02356"></a>02356 Error_1(sc,<span class="stringliteral">"syntax error in closure: not a symbol:"</span>, x);
<a name="l02357"></a>02357 }
<a name="l02358"></a>02358 sc-&gt;code = cdr(closure_code(sc-&gt;code));
<a name="l02359"></a>02359 sc-&gt;args = sc-&gt;NIL;
<a name="l02360"></a>02360 s_goto(sc,OP_BEGIN);
<a name="l02361"></a>02361 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_continuation(sc-&gt;code)) { <span class="comment">/* CONTINUATION */</span>
<a name="l02362"></a>02362 sc-&gt;dump = cont_dump(sc-&gt;code);
<a name="l02363"></a>02363 s_return(sc,sc-&gt;args != sc-&gt;NIL ? car(sc-&gt;args) : sc-&gt;NIL);
<a name="l02364"></a>02364 } <span class="keywordflow">else</span> {
<a name="l02365"></a>02365 Error_0(sc,<span class="stringliteral">"illegal function"</span>);
<a name="l02366"></a>02366 }
<a name="l02367"></a>02367
<a name="l02368"></a>02368 <span class="keywordflow">case</span> OP_DOMACRO: <span class="comment">/* do macro */</span>
<a name="l02369"></a>02369 sc-&gt;code = sc-&gt;value;
<a name="l02370"></a>02370 s_goto(sc,OP_EVAL);
<a name="l02371"></a>02371
<a name="l02372"></a>02372 <span class="keywordflow">case</span> OP_LAMBDA: <span class="comment">/* lambda */</span>
<a name="l02373"></a>02373 s_return(sc,mk_closure(sc, sc-&gt;code, sc-&gt;envir));
<a name="l02374"></a>02374
<a name="l02375"></a>02375 <span class="keywordflow">case</span> OP_MKCLOSURE: <span class="comment">/* make-closure */</span>
<a name="l02376"></a>02376 x=car(sc-&gt;args);
<a name="l02377"></a>02377 <span class="keywordflow">if</span>(car(x)==sc-&gt;LAMBDA) {
<a name="l02378"></a>02378 x=cdr(x);
<a name="l02379"></a>02379 }
<a name="l02380"></a>02380 <span class="keywordflow">if</span>(cdr(sc-&gt;args)==sc-&gt;NIL) {
<a name="l02381"></a>02381 y=sc-&gt;envir;
<a name="l02382"></a>02382 } <span class="keywordflow">else</span> {
<a name="l02383"></a>02383 y=cadr(sc-&gt;args);
<a name="l02384"></a>02384 }
<a name="l02385"></a>02385 s_return(sc,mk_closure(sc, x, y));
<a name="l02386"></a>02386
<a name="l02387"></a>02387 <span class="keywordflow">case</span> OP_QUOTE: <span class="comment">/* quote */</span>
<a name="l02388"></a>02388 x=car(sc-&gt;code);
<a name="l02389"></a>02389 s_return(sc,car(sc-&gt;code));
<a name="l02390"></a>02390
<a name="l02391"></a>02391 <span class="keywordflow">case</span> OP_DEF0: <span class="comment">/* define */</span>
<a name="l02392"></a>02392 <span class="keywordflow">if</span> (is_pair(car(sc-&gt;code))) {
<a name="l02393"></a>02393 x = caar(sc-&gt;code);
<a name="l02394"></a>02394 sc-&gt;code = cons(sc, sc-&gt;LAMBDA, cons(sc, cdar(sc-&gt;code), cdr(sc-&gt;code)));
<a name="l02395"></a>02395 } <span class="keywordflow">else</span> {
<a name="l02396"></a>02396 x = car(sc-&gt;code);
<a name="l02397"></a>02397 sc-&gt;code = cadr(sc-&gt;code);
<a name="l02398"></a>02398 }
<a name="l02399"></a>02399 <span class="keywordflow">if</span> (!is_symbol(x)) {
<a name="l02400"></a>02400 Error_0(sc,<span class="stringliteral">"variable is not a symbol"</span>);
<a name="l02401"></a>02401 }
<a name="l02402"></a>02402 s_save(sc,OP_DEF1, sc-&gt;NIL, x);
<a name="l02403"></a>02403 s_goto(sc,OP_EVAL);
<a name="l02404"></a>02404
<a name="l02405"></a>02405 <span class="keywordflow">case</span> OP_DEF1: <span class="comment">/* define */</span>
<a name="l02406"></a>02406 x=find_slot_in_env(sc,sc-&gt;envir,sc-&gt;code,0);
<a name="l02407"></a>02407 <span class="keywordflow">if</span> (x != sc-&gt;NIL) {
<a name="l02408"></a>02408 set_slot_in_env(sc, x, sc-&gt;value);
<a name="l02409"></a>02409 } <span class="keywordflow">else</span> {
<a name="l02410"></a>02410 new_slot_in_env(sc, sc-&gt;code, sc-&gt;value);
<a name="l02411"></a>02411 }
<a name="l02412"></a>02412 s_return(sc,sc-&gt;code);
<a name="l02413"></a>02413
<a name="l02414"></a>02414
<a name="l02415"></a>02415 <span class="keywordflow">case</span> OP_DEFP: <span class="comment">/* defined? */</span>
<a name="l02416"></a>02416 x=sc-&gt;envir;
<a name="l02417"></a>02417 <span class="keywordflow">if</span>(cdr(sc-&gt;args)!=sc-&gt;NIL) {
<a name="l02418"></a>02418 x=cadr(sc-&gt;args);
<a name="l02419"></a>02419 }
<a name="l02420"></a>02420 s_retbool(find_slot_in_env(sc,x,car(sc-&gt;args),1)!=sc-&gt;NIL);
<a name="l02421"></a>02421
<a name="l02422"></a>02422 <span class="keywordflow">case</span> OP_SET0: <span class="comment">/* set! */</span>
<a name="l02423"></a>02423 s_save(sc,OP_SET1, sc-&gt;NIL, car(sc-&gt;code));
<a name="l02424"></a>02424 sc-&gt;code = cadr(sc-&gt;code);
<a name="l02425"></a>02425 s_goto(sc,OP_EVAL);
<a name="l02426"></a>02426
<a name="l02427"></a>02427 <span class="keywordflow">case</span> OP_SET1: <span class="comment">/* set! */</span>
<a name="l02428"></a>02428 y=find_slot_in_env(sc,sc-&gt;envir,sc-&gt;code,1);
<a name="l02429"></a>02429 <span class="keywordflow">if</span> (y != sc-&gt;NIL) {
<a name="l02430"></a>02430 set_slot_in_env(sc, y, sc-&gt;value);
<a name="l02431"></a>02431 s_return(sc,sc-&gt;value);
<a name="l02432"></a>02432 } <span class="keywordflow">else</span> {
<a name="l02433"></a>02433 Error_1(sc,<span class="stringliteral">"set!: unbound variable:"</span>, sc-&gt;code);
<a name="l02434"></a>02434 }
<a name="l02435"></a>02435
<a name="l02436"></a>02436
<a name="l02437"></a>02437 <span class="keywordflow">case</span> OP_BEGIN: <span class="comment">/* begin */</span>
<a name="l02438"></a>02438 <span class="keywordflow">if</span> (!is_pair(sc-&gt;code)) {
<a name="l02439"></a>02439 s_return(sc,sc-&gt;code);
<a name="l02440"></a>02440 }
<a name="l02441"></a>02441 <span class="keywordflow">if</span> (cdr(sc-&gt;code) != sc-&gt;NIL) {
<a name="l02442"></a>02442 s_save(sc,OP_BEGIN, sc-&gt;NIL, cdr(sc-&gt;code));
<a name="l02443"></a>02443 }
<a name="l02444"></a>02444 sc-&gt;code = car(sc-&gt;code);
<a name="l02445"></a>02445 s_goto(sc,OP_EVAL);
<a name="l02446"></a>02446
<a name="l02447"></a>02447 <span class="keywordflow">case</span> OP_IF0: <span class="comment">/* if */</span>
<a name="l02448"></a>02448 s_save(sc,OP_IF1, sc-&gt;NIL, cdr(sc-&gt;code));
<a name="l02449"></a>02449 sc-&gt;code = car(sc-&gt;code);
<a name="l02450"></a>02450 s_goto(sc,OP_EVAL);
<a name="l02451"></a>02451
<a name="l02452"></a>02452 <span class="keywordflow">case</span> OP_IF1: <span class="comment">/* if */</span>
<a name="l02453"></a>02453 <span class="keywordflow">if</span> (is_true(sc-&gt;value))
<a name="l02454"></a>02454 sc-&gt;code = car(sc-&gt;code);
<a name="l02455"></a>02455 <span class="keywordflow">else</span>
<a name="l02456"></a>02456 sc-&gt;code = cadr(sc-&gt;code); <span class="comment">/* (if #f 1) ==&gt; () because</span>
<a name="l02457"></a>02457 <span class="comment"> * car(sc-&gt;NIL) = sc-&gt;NIL */</span>
<a name="l02458"></a>02458 s_goto(sc,OP_EVAL);
<a name="l02459"></a>02459
<a name="l02460"></a>02460 <span class="keywordflow">case</span> OP_LET0: <span class="comment">/* let */</span>
<a name="l02461"></a>02461 sc-&gt;args = sc-&gt;NIL;
<a name="l02462"></a>02462 sc-&gt;value = sc-&gt;code;
<a name="l02463"></a>02463 sc-&gt;code = is_symbol(car(sc-&gt;code)) ? cadr(sc-&gt;code) : car(sc-&gt;code);
<a name="l02464"></a>02464 s_goto(sc,OP_LET1);
<a name="l02465"></a>02465
<a name="l02466"></a>02466 <span class="keywordflow">case</span> OP_LET1: <span class="comment">/* let (calculate parameters) */</span>
<a name="l02467"></a>02467 sc-&gt;args = cons(sc, sc-&gt;value, sc-&gt;args);
<a name="l02468"></a>02468 <span class="keywordflow">if</span> (is_pair(sc-&gt;code)) { <span class="comment">/* continue */</span>
<a name="l02469"></a>02469 s_save(sc,OP_LET1, sc-&gt;args, cdr(sc-&gt;code));
<a name="l02470"></a>02470 sc-&gt;code = cadar(sc-&gt;code);
<a name="l02471"></a>02471 sc-&gt;args = sc-&gt;NIL;
<a name="l02472"></a>02472 s_goto(sc,OP_EVAL);
<a name="l02473"></a>02473 } <span class="keywordflow">else</span> { <span class="comment">/* end */</span>
<a name="l02474"></a>02474 sc-&gt;args = reverse_in_place(sc, sc-&gt;NIL, sc-&gt;args);
<a name="l02475"></a>02475 sc-&gt;code = car(sc-&gt;args);
<a name="l02476"></a>02476 sc-&gt;args = cdr(sc-&gt;args);
<a name="l02477"></a>02477 s_goto(sc,OP_LET2);
<a name="l02478"></a>02478 }
<a name="l02479"></a>02479
<a name="l02480"></a>02480 <span class="keywordflow">case</span> OP_LET2: <span class="comment">/* let */</span>
<a name="l02481"></a>02481 new_frame_in_env(sc, sc-&gt;envir);
<a name="l02482"></a>02482 <span class="keywordflow">for</span> (x = is_symbol(car(sc-&gt;code)) ? cadr(sc-&gt;code) : car(sc-&gt;code), y = sc-&gt;args;
<a name="l02483"></a>02483 y != sc-&gt;NIL; x = cdr(x), y = cdr(y)) {
<a name="l02484"></a>02484 new_slot_in_env(sc, caar(x), car(y));
<a name="l02485"></a>02485 }
<a name="l02486"></a>02486 <span class="keywordflow">if</span> (is_symbol(car(sc-&gt;code))) { <span class="comment">/* named let */</span>
<a name="l02487"></a>02487 <span class="keywordflow">for</span> (x = cadr(sc-&gt;code), sc-&gt;args = sc-&gt;NIL; x != sc-&gt;NIL; x = cdr(x)) {
<a name="l02488"></a>02488
<a name="l02489"></a>02489 sc-&gt;args = cons(sc, caar(x), sc-&gt;args);
<a name="l02490"></a>02490 }
<a name="l02491"></a>02491 x = mk_closure(sc, cons(sc, reverse_in_place(sc, sc-&gt;NIL, sc-&gt;args), cddr(sc-&gt;code)), sc-&gt;envir);
<a name="l02492"></a>02492 new_slot_in_env(sc, car(sc-&gt;code), x);
<a name="l02493"></a>02493 sc-&gt;code = cddr(sc-&gt;code);
<a name="l02494"></a>02494 sc-&gt;args = sc-&gt;NIL;
<a name="l02495"></a>02495 } <span class="keywordflow">else</span> {
<a name="l02496"></a>02496 sc-&gt;code = cdr(sc-&gt;code);
<a name="l02497"></a>02497 sc-&gt;args = sc-&gt;NIL;
<a name="l02498"></a>02498 }
<a name="l02499"></a>02499 s_goto(sc,OP_BEGIN);
<a name="l02500"></a>02500
<a name="l02501"></a>02501 <span class="keywordflow">case</span> OP_LET0AST: <span class="comment">/* let* */</span>
<a name="l02502"></a>02502 <span class="keywordflow">if</span> (car(sc-&gt;code) == sc-&gt;NIL) {
<a name="l02503"></a>02503 new_frame_in_env(sc, sc-&gt;envir);
<a name="l02504"></a>02504 sc-&gt;code = cdr(sc-&gt;code);
<a name="l02505"></a>02505 s_goto(sc,OP_BEGIN);
<a name="l02506"></a>02506 }
<a name="l02507"></a>02507 s_save(sc,OP_LET1AST, cdr(sc-&gt;code), car(sc-&gt;code));
<a name="l02508"></a>02508 sc-&gt;code = cadaar(sc-&gt;code);
<a name="l02509"></a>02509 s_goto(sc,OP_EVAL);
<a name="l02510"></a>02510
<a name="l02511"></a>02511 <span class="keywordflow">case</span> OP_LET1AST: <span class="comment">/* let* (make new frame) */</span>
<a name="l02512"></a>02512 new_frame_in_env(sc, sc-&gt;envir);
<a name="l02513"></a>02513 s_goto(sc,OP_LET2AST);
<a name="l02514"></a>02514
<a name="l02515"></a>02515 <span class="keywordflow">case</span> OP_LET2AST: <span class="comment">/* let* (calculate parameters) */</span>
<a name="l02516"></a>02516 new_slot_in_env(sc, caar(sc-&gt;code), sc-&gt;value);
<a name="l02517"></a>02517 sc-&gt;code = cdr(sc-&gt;code);
<a name="l02518"></a>02518 <span class="keywordflow">if</span> (is_pair(sc-&gt;code)) { <span class="comment">/* continue */</span>
<a name="l02519"></a>02519 s_save(sc,OP_LET2AST, sc-&gt;args, sc-&gt;code);
<a name="l02520"></a>02520 sc-&gt;code = cadar(sc-&gt;code);
<a name="l02521"></a>02521 sc-&gt;args = sc-&gt;NIL;
<a name="l02522"></a>02522 s_goto(sc,OP_EVAL);
<a name="l02523"></a>02523 } <span class="keywordflow">else</span> { <span class="comment">/* end */</span>
<a name="l02524"></a>02524 sc-&gt;code = sc-&gt;args;
<a name="l02525"></a>02525 sc-&gt;args = sc-&gt;NIL;
<a name="l02526"></a>02526 s_goto(sc,OP_BEGIN);
<a name="l02527"></a>02527 }
<a name="l02528"></a>02528 <span class="keywordflow">default</span>:
<a name="l02529"></a>02529 sprintf(sc-&gt;strbuff, <span class="stringliteral">"%d: illegal operator"</span>, sc-&gt;op);
<a name="l02530"></a>02530 Error_0(sc,sc-&gt;strbuff);
<a name="l02531"></a>02531 }
<a name="l02532"></a>02532 <span class="keywordflow">return</span> sc-&gt;T;
<a name="l02533"></a>02533 }
<a name="l02534"></a>02534
<a name="l02535"></a>02535 <span class="keyword">static</span> pointer opexe_1(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op) {
<a name="l02536"></a>02536 pointer x, y;
<a name="l02537"></a>02537
<a name="l02538"></a>02538 <span class="keywordflow">switch</span> (op) {
<a name="l02539"></a>02539 <span class="keywordflow">case</span> OP_LET0REC: <span class="comment">/* letrec */</span>
<a name="l02540"></a>02540 new_frame_in_env(sc, sc-&gt;envir);
<a name="l02541"></a>02541 sc-&gt;args = sc-&gt;NIL;
<a name="l02542"></a>02542 sc-&gt;value = sc-&gt;code;
<a name="l02543"></a>02543 sc-&gt;code = car(sc-&gt;code);
<a name="l02544"></a>02544 s_goto(sc,OP_LET1REC);
<a name="l02545"></a>02545
<a name="l02546"></a>02546 <span class="keywordflow">case</span> OP_LET1REC: <span class="comment">/* letrec (calculate parameters) */</span>
<a name="l02547"></a>02547 sc-&gt;args = cons(sc, sc-&gt;value, sc-&gt;args);
<a name="l02548"></a>02548 <span class="keywordflow">if</span> (is_pair(sc-&gt;code)) { <span class="comment">/* continue */</span>
<a name="l02549"></a>02549 s_save(sc,OP_LET1REC, sc-&gt;args, cdr(sc-&gt;code));
<a name="l02550"></a>02550 sc-&gt;code = cadar(sc-&gt;code);
<a name="l02551"></a>02551 sc-&gt;args = sc-&gt;NIL;
<a name="l02552"></a>02552 s_goto(sc,OP_EVAL);
<a name="l02553"></a>02553 } <span class="keywordflow">else</span> { <span class="comment">/* end */</span>
<a name="l02554"></a>02554 sc-&gt;args = reverse_in_place(sc, sc-&gt;NIL, sc-&gt;args);
<a name="l02555"></a>02555 sc-&gt;code = car(sc-&gt;args);
<a name="l02556"></a>02556 sc-&gt;args = cdr(sc-&gt;args);
<a name="l02557"></a>02557 s_goto(sc,OP_LET2REC);
<a name="l02558"></a>02558 }
<a name="l02559"></a>02559
<a name="l02560"></a>02560 <span class="keywordflow">case</span> OP_LET2REC: <span class="comment">/* letrec */</span>
<a name="l02561"></a>02561 <span class="keywordflow">for</span> (x = car(sc-&gt;code), y = sc-&gt;args; y != sc-&gt;NIL; x = cdr(x), y = cdr(y)) {
<a name="l02562"></a>02562 new_slot_in_env(sc, caar(x), car(y));
<a name="l02563"></a>02563 }
<a name="l02564"></a>02564 sc-&gt;code = cdr(sc-&gt;code);
<a name="l02565"></a>02565 sc-&gt;args = sc-&gt;NIL;
<a name="l02566"></a>02566 s_goto(sc,OP_BEGIN);
<a name="l02567"></a>02567
<a name="l02568"></a>02568 <span class="keywordflow">case</span> OP_COND0: <span class="comment">/* cond */</span>
<a name="l02569"></a>02569 <span class="keywordflow">if</span> (!is_pair(sc-&gt;code)) {
<a name="l02570"></a>02570 Error_0(sc,<span class="stringliteral">"syntax error in cond"</span>);
<a name="l02571"></a>02571 }
<a name="l02572"></a>02572 s_save(sc,OP_COND1, sc-&gt;NIL, sc-&gt;code);
<a name="l02573"></a>02573 sc-&gt;code = caar(sc-&gt;code);
<a name="l02574"></a>02574 s_goto(sc,OP_EVAL);
<a name="l02575"></a>02575
<a name="l02576"></a>02576 <span class="keywordflow">case</span> OP_COND1: <span class="comment">/* cond */</span>
<a name="l02577"></a>02577 <span class="keywordflow">if</span> (is_true(sc-&gt;value)) {
<a name="l02578"></a>02578 <span class="keywordflow">if</span> ((sc-&gt;code = cdar(sc-&gt;code)) == sc-&gt;NIL) {
<a name="l02579"></a>02579 s_return(sc,sc-&gt;value);
<a name="l02580"></a>02580 }
<a name="l02581"></a>02581 <span class="keywordflow">if</span>(car(sc-&gt;code)==sc-&gt;FEED_TO) {
<a name="l02582"></a>02582 <span class="keywordflow">if</span>(!is_pair(cdr(sc-&gt;code))) {
<a name="l02583"></a>02583 Error_0(sc,<span class="stringliteral">"syntax error in cond"</span>);
<a name="l02584"></a>02584 }
<a name="l02585"></a>02585 x=cons(sc, sc-&gt;QUOTE, cons(sc, sc-&gt;value, sc-&gt;NIL));
<a name="l02586"></a>02586 sc-&gt;code=cons(sc,cadr(sc-&gt;code),cons(sc,x,sc-&gt;NIL));
<a name="l02587"></a>02587 s_goto(sc,OP_EVAL);
<a name="l02588"></a>02588 }
<a name="l02589"></a>02589 s_goto(sc,OP_BEGIN);
<a name="l02590"></a>02590 } <span class="keywordflow">else</span> {
<a name="l02591"></a>02591 <span class="keywordflow">if</span> ((sc-&gt;code = cdr(sc-&gt;code)) == sc-&gt;NIL) {
<a name="l02592"></a>02592 s_return(sc,sc-&gt;NIL);
<a name="l02593"></a>02593 } <span class="keywordflow">else</span> {
<a name="l02594"></a>02594 s_save(sc,OP_COND1, sc-&gt;NIL, sc-&gt;code);
<a name="l02595"></a>02595 sc-&gt;code = caar(sc-&gt;code);
<a name="l02596"></a>02596 s_goto(sc,OP_EVAL);
<a name="l02597"></a>02597 }
<a name="l02598"></a>02598 }
<a name="l02599"></a>02599
<a name="l02600"></a>02600 <span class="keywordflow">case</span> OP_DELAY: <span class="comment">/* delay */</span>
<a name="l02601"></a>02601 x = mk_closure(sc, cons(sc, sc-&gt;NIL, sc-&gt;code), sc-&gt;envir);
<a name="l02602"></a>02602 typeflag(x)=T_PROMISE;
<a name="l02603"></a>02603 s_return(sc,x);
<a name="l02604"></a>02604
<a name="l02605"></a>02605 <span class="keywordflow">case</span> OP_AND0: <span class="comment">/* and */</span>
<a name="l02606"></a>02606 <span class="keywordflow">if</span> (sc-&gt;code == sc-&gt;NIL) {
<a name="l02607"></a>02607 s_return(sc,sc-&gt;T);
<a name="l02608"></a>02608 }
<a name="l02609"></a>02609 s_save(sc,OP_AND1, sc-&gt;NIL, cdr(sc-&gt;code));
<a name="l02610"></a>02610 sc-&gt;code = car(sc-&gt;code);
<a name="l02611"></a>02611 s_goto(sc,OP_EVAL);
<a name="l02612"></a>02612
<a name="l02613"></a>02613 <span class="keywordflow">case</span> OP_AND1: <span class="comment">/* and */</span>
<a name="l02614"></a>02614 <span class="keywordflow">if</span> (is_false(sc-&gt;value)) {
<a name="l02615"></a>02615 s_return(sc,sc-&gt;value);
<a name="l02616"></a>02616 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (sc-&gt;code == sc-&gt;NIL) {
<a name="l02617"></a>02617 s_return(sc,sc-&gt;value);
<a name="l02618"></a>02618 } <span class="keywordflow">else</span> {
<a name="l02619"></a>02619 s_save(sc,OP_AND1, sc-&gt;NIL, cdr(sc-&gt;code));
<a name="l02620"></a>02620 sc-&gt;code = car(sc-&gt;code);
<a name="l02621"></a>02621 s_goto(sc,OP_EVAL);
<a name="l02622"></a>02622 }
<a name="l02623"></a>02623
<a name="l02624"></a>02624 <span class="keywordflow">case</span> OP_OR0: <span class="comment">/* or */</span>
<a name="l02625"></a>02625 <span class="keywordflow">if</span> (sc-&gt;code == sc-&gt;NIL) {
<a name="l02626"></a>02626 s_return(sc,sc-&gt;F);
<a name="l02627"></a>02627 }
<a name="l02628"></a>02628 s_save(sc,OP_OR1, sc-&gt;NIL, cdr(sc-&gt;code));
<a name="l02629"></a>02629 sc-&gt;code = car(sc-&gt;code);
<a name="l02630"></a>02630 s_goto(sc,OP_EVAL);
<a name="l02631"></a>02631
<a name="l02632"></a>02632 <span class="keywordflow">case</span> OP_OR1: <span class="comment">/* or */</span>
<a name="l02633"></a>02633 <span class="keywordflow">if</span> (is_true(sc-&gt;value)) {
<a name="l02634"></a>02634 s_return(sc,sc-&gt;value);
<a name="l02635"></a>02635 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (sc-&gt;code == sc-&gt;NIL) {
<a name="l02636"></a>02636 s_return(sc,sc-&gt;value);
<a name="l02637"></a>02637 } <span class="keywordflow">else</span> {
<a name="l02638"></a>02638 s_save(sc,OP_OR1, sc-&gt;NIL, cdr(sc-&gt;code));
<a name="l02639"></a>02639 sc-&gt;code = car(sc-&gt;code);
<a name="l02640"></a>02640 s_goto(sc,OP_EVAL);
<a name="l02641"></a>02641 }
<a name="l02642"></a>02642
<a name="l02643"></a>02643 <span class="keywordflow">case</span> OP_C0STREAM: <span class="comment">/* cons-stream */</span>
<a name="l02644"></a>02644 s_save(sc,OP_C1STREAM, sc-&gt;NIL, cdr(sc-&gt;code));
<a name="l02645"></a>02645 sc-&gt;code = car(sc-&gt;code);
<a name="l02646"></a>02646 s_goto(sc,OP_EVAL);
<a name="l02647"></a>02647
<a name="l02648"></a>02648 <span class="keywordflow">case</span> OP_C1STREAM: <span class="comment">/* cons-stream */</span>
<a name="l02649"></a>02649 sc-&gt;args = sc-&gt;value; <span class="comment">/* save sc-&gt;value to register sc-&gt;args for gc */</span>
<a name="l02650"></a>02650 x = mk_closure(sc, cons(sc, sc-&gt;NIL, sc-&gt;code), sc-&gt;envir);
<a name="l02651"></a>02651 typeflag(x)=T_PROMISE;
<a name="l02652"></a>02652 s_return(sc,cons(sc, sc-&gt;args, x));
<a name="l02653"></a>02653
<a name="l02654"></a>02654 <span class="keywordflow">case</span> OP_MACRO0: <span class="comment">/* macro */</span>
<a name="l02655"></a>02655 <span class="keywordflow">if</span> (is_pair(car(sc-&gt;code))) {
<a name="l02656"></a>02656 x = caar(sc-&gt;code);
<a name="l02657"></a>02657 sc-&gt;code = cons(sc, sc-&gt;LAMBDA, cons(sc, cdar(sc-&gt;code), cdr(sc-&gt;code)));
<a name="l02658"></a>02658 } <span class="keywordflow">else</span> {
<a name="l02659"></a>02659 x = car(sc-&gt;code);
<a name="l02660"></a>02660 sc-&gt;code = cadr(sc-&gt;code);
<a name="l02661"></a>02661 }
<a name="l02662"></a>02662 <span class="keywordflow">if</span> (!is_symbol(x)) {
<a name="l02663"></a>02663 Error_0(sc,<span class="stringliteral">"variable is not a symbol"</span>);
<a name="l02664"></a>02664 }
<a name="l02665"></a>02665 s_save(sc,OP_MACRO1, sc-&gt;NIL, x);
<a name="l02666"></a>02666 s_goto(sc,OP_EVAL);
<a name="l02667"></a>02667
<a name="l02668"></a>02668 <span class="keywordflow">case</span> OP_MACRO1: <span class="comment">/* macro */</span>
<a name="l02669"></a>02669 typeflag(sc-&gt;value) = T_MACRO;
<a name="l02670"></a>02670 x = find_slot_in_env(sc, sc-&gt;envir, sc-&gt;code, 0);
<a name="l02671"></a>02671 <span class="keywordflow">if</span> (x != sc-&gt;NIL) {
<a name="l02672"></a>02672 set_slot_in_env(sc, x, sc-&gt;value);
<a name="l02673"></a>02673 } <span class="keywordflow">else</span> {
<a name="l02674"></a>02674 new_slot_in_env(sc, sc-&gt;code, sc-&gt;value);
<a name="l02675"></a>02675 }
<a name="l02676"></a>02676 s_return(sc,sc-&gt;code);
<a name="l02677"></a>02677
<a name="l02678"></a>02678 <span class="keywordflow">case</span> OP_CASE0: <span class="comment">/* case */</span>
<a name="l02679"></a>02679 s_save(sc,OP_CASE1, sc-&gt;NIL, cdr(sc-&gt;code));
<a name="l02680"></a>02680 sc-&gt;code = car(sc-&gt;code);
<a name="l02681"></a>02681 s_goto(sc,OP_EVAL);
<a name="l02682"></a>02682
<a name="l02683"></a>02683 <span class="keywordflow">case</span> OP_CASE1: <span class="comment">/* case */</span>
<a name="l02684"></a>02684 <span class="keywordflow">for</span> (x = sc-&gt;code; x != sc-&gt;NIL; x = cdr(x)) {
<a name="l02685"></a>02685 <span class="keywordflow">if</span> (!is_pair(y = caar(x))) {
<a name="l02686"></a>02686 <span class="keywordflow">break</span>;
<a name="l02687"></a>02687 }
<a name="l02688"></a>02688 <span class="keywordflow">for</span> ( ; y != sc-&gt;NIL; y = cdr(y)) {
<a name="l02689"></a>02689 <span class="keywordflow">if</span> (eqv(car(y), sc-&gt;value)) {
<a name="l02690"></a>02690 <span class="keywordflow">break</span>;
<a name="l02691"></a>02691 }
<a name="l02692"></a>02692 }
<a name="l02693"></a>02693 <span class="keywordflow">if</span> (y != sc-&gt;NIL) {
<a name="l02694"></a>02694 <span class="keywordflow">break</span>;
<a name="l02695"></a>02695 }
<a name="l02696"></a>02696 }
<a name="l02697"></a>02697 <span class="keywordflow">if</span> (x != sc-&gt;NIL) {
<a name="l02698"></a>02698 <span class="keywordflow">if</span> (is_pair(caar(x))) {
<a name="l02699"></a>02699 sc-&gt;code = cdar(x);
<a name="l02700"></a>02700 s_goto(sc,OP_BEGIN);
<a name="l02701"></a>02701 } <span class="keywordflow">else</span> {<span class="comment">/* else */</span>
<a name="l02702"></a>02702 s_save(sc,OP_CASE2, sc-&gt;NIL, cdar(x));
<a name="l02703"></a>02703 sc-&gt;code = caar(x);
<a name="l02704"></a>02704 s_goto(sc,OP_EVAL);
<a name="l02705"></a>02705 }
<a name="l02706"></a>02706 } <span class="keywordflow">else</span> {
<a name="l02707"></a>02707 s_return(sc,sc-&gt;NIL);
<a name="l02708"></a>02708 }
<a name="l02709"></a>02709
<a name="l02710"></a>02710 <span class="keywordflow">case</span> OP_CASE2: <span class="comment">/* case */</span>
<a name="l02711"></a>02711 <span class="keywordflow">if</span> (is_true(sc-&gt;value)) {
<a name="l02712"></a>02712 s_goto(sc,OP_BEGIN);
<a name="l02713"></a>02713 } <span class="keywordflow">else</span> {
<a name="l02714"></a>02714 s_return(sc,sc-&gt;NIL);
<a name="l02715"></a>02715 }
<a name="l02716"></a>02716
<a name="l02717"></a>02717 <span class="keywordflow">case</span> OP_PAPPLY: <span class="comment">/* apply */</span>
<a name="l02718"></a>02718 sc-&gt;code = car(sc-&gt;args);
<a name="l02719"></a>02719 sc-&gt;args = list_star(sc,cdr(sc-&gt;args));
<a name="l02720"></a>02720 <span class="comment">/*sc-&gt;args = cadr(sc-&gt;args);*/</span>
<a name="l02721"></a>02721 s_goto(sc,OP_APPLY);
<a name="l02722"></a>02722
<a name="l02723"></a>02723 <span class="keywordflow">case</span> OP_PEVAL: <span class="comment">/* eval */</span>
<a name="l02724"></a>02724 <span class="keywordflow">if</span>(cdr(sc-&gt;args)!=sc-&gt;NIL) {
<a name="l02725"></a>02725 sc-&gt;envir=cadr(sc-&gt;args);
<a name="l02726"></a>02726 }
<a name="l02727"></a>02727 sc-&gt;code = car(sc-&gt;args);
<a name="l02728"></a>02728 s_goto(sc,OP_EVAL);
<a name="l02729"></a>02729
<a name="l02730"></a>02730 <span class="keywordflow">case</span> OP_CONTINUATION: <span class="comment">/* call-with-current-continuation */</span>
<a name="l02731"></a>02731 sc-&gt;code = car(sc-&gt;args);
<a name="l02732"></a>02732 sc-&gt;args = cons(sc, mk_continuation(sc, sc-&gt;dump), sc-&gt;NIL);
<a name="l02733"></a>02733 s_goto(sc,OP_APPLY);
<a name="l02734"></a>02734
<a name="l02735"></a>02735 <span class="keywordflow">default</span>:
<a name="l02736"></a>02736 sprintf(sc-&gt;strbuff, <span class="stringliteral">"%d: illegal operator"</span>, sc-&gt;op);
<a name="l02737"></a>02737 Error_0(sc,sc-&gt;strbuff);
<a name="l02738"></a>02738 }
<a name="l02739"></a>02739 <span class="keywordflow">return</span> sc-&gt;T;
<a name="l02740"></a>02740 }
<a name="l02741"></a>02741
<a name="l02742"></a>02742 <span class="keyword">static</span> pointer opexe_2(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op) {
<a name="l02743"></a>02743 pointer x;
<a name="l02744"></a>02744 num v;
<a name="l02745"></a>02745 <span class="preprocessor">#if USE_MATH</span>
<a name="l02746"></a>02746 <span class="preprocessor"></span> <span class="keywordtype">double</span> dd;
<a name="l02747"></a>02747 <span class="preprocessor">#endif</span>
<a name="l02748"></a>02748 <span class="preprocessor"></span>
<a name="l02749"></a>02749 <span class="keywordflow">switch</span> (op) {
<a name="l02750"></a>02750 <span class="preprocessor">#if USE_MATH</span>
<a name="l02751"></a>02751 <span class="preprocessor"></span> <span class="keywordflow">case</span> OP_INEX2EX: <span class="comment">/* inexact-&gt;exact */</span>
<a name="l02752"></a>02752 x=car(sc-&gt;args);
<a name="l02753"></a>02753 <span class="keywordflow">if</span>(is_integer(x)) {
<a name="l02754"></a>02754 s_return(sc,x);
<a name="l02755"></a>02755 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(modf(rvalue_unchecked(x),&amp;dd)==0.0) {
<a name="l02756"></a>02756 s_return(sc,mk_integer(sc,ivalue(x)));
<a name="l02757"></a>02757 } <span class="keywordflow">else</span> {
<a name="l02758"></a>02758 Error_1(sc,<span class="stringliteral">"inexact-&gt;exact: not integral:"</span>,x);
<a name="l02759"></a>02759 }
<a name="l02760"></a>02760
<a name="l02761"></a>02761 <span class="keywordflow">case</span> OP_EXP:
<a name="l02762"></a>02762 x=car(sc-&gt;args);
<a name="l02763"></a>02763 s_return(sc, mk_real(sc, exp(rvalue(x))));
<a name="l02764"></a>02764
<a name="l02765"></a>02765 <span class="keywordflow">case</span> OP_LOG:
<a name="l02766"></a>02766 x=car(sc-&gt;args);
<a name="l02767"></a>02767 s_return(sc, mk_real(sc, log(rvalue(x))));
<a name="l02768"></a>02768
<a name="l02769"></a>02769 <span class="keywordflow">case</span> OP_SIN:
<a name="l02770"></a>02770 x=car(sc-&gt;args);
<a name="l02771"></a>02771 s_return(sc, mk_real(sc, sin(rvalue(x))));
<a name="l02772"></a>02772
<a name="l02773"></a>02773 <span class="keywordflow">case</span> OP_COS:
<a name="l02774"></a>02774 x=car(sc-&gt;args);
<a name="l02775"></a>02775 s_return(sc, mk_real(sc, cos(rvalue(x))));
<a name="l02776"></a>02776
<a name="l02777"></a>02777 <span class="keywordflow">case</span> OP_TAN:
<a name="l02778"></a>02778 x=car(sc-&gt;args);
<a name="l02779"></a>02779 s_return(sc, mk_real(sc, tan(rvalue(x))));
<a name="l02780"></a>02780
<a name="l02781"></a>02781 <span class="keywordflow">case</span> OP_ASIN:
<a name="l02782"></a>02782 x=car(sc-&gt;args);
<a name="l02783"></a>02783 s_return(sc, mk_real(sc, asin(rvalue(x))));
<a name="l02784"></a>02784
<a name="l02785"></a>02785 <span class="keywordflow">case</span> OP_ACOS:
<a name="l02786"></a>02786 x=car(sc-&gt;args);
<a name="l02787"></a>02787 s_return(sc, mk_real(sc, acos(rvalue(x))));
<a name="l02788"></a>02788
<a name="l02789"></a>02789 <span class="keywordflow">case</span> OP_ATAN:
<a name="l02790"></a>02790 x=car(sc-&gt;args);
<a name="l02791"></a>02791 <span class="keywordflow">if</span>(cdr(sc-&gt;args)==sc-&gt;NIL) {
<a name="l02792"></a>02792 s_return(sc, mk_real(sc, atan(rvalue(x))));
<a name="l02793"></a>02793 } <span class="keywordflow">else</span> {
<a name="l02794"></a>02794 pointer y=cadr(sc-&gt;args);
<a name="l02795"></a>02795 s_return(sc, mk_real(sc, atan2(rvalue(x),rvalue(y))));
<a name="l02796"></a>02796 }
<a name="l02797"></a>02797
<a name="l02798"></a>02798 <span class="keywordflow">case</span> OP_SQRT:
<a name="l02799"></a>02799 x=car(sc-&gt;args);
<a name="l02800"></a>02800 s_return(sc, mk_real(sc, sqrt(rvalue(x))));
<a name="l02801"></a>02801
<a name="l02802"></a>02802 <span class="keywordflow">case</span> OP_EXPT:
<a name="l02803"></a>02803 x=car(sc-&gt;args);
<a name="l02804"></a>02804 <span class="keywordflow">if</span>(cdr(sc-&gt;args)==sc-&gt;NIL) {
<a name="l02805"></a>02805 Error_0(sc,<span class="stringliteral">"expt: needs two arguments"</span>);
<a name="l02806"></a>02806 } <span class="keywordflow">else</span> {
<a name="l02807"></a>02807 pointer y=cadr(sc-&gt;args);
<a name="l02808"></a>02808 s_return(sc, mk_real(sc, pow(rvalue(x),rvalue(y))));
<a name="l02809"></a>02809 }
<a name="l02810"></a>02810
<a name="l02811"></a>02811 <span class="keywordflow">case</span> OP_FLOOR:
<a name="l02812"></a>02812 x=car(sc-&gt;args);
<a name="l02813"></a>02813 s_return(sc, mk_real(sc, floor(rvalue(x))));
<a name="l02814"></a>02814
<a name="l02815"></a>02815 <span class="keywordflow">case</span> OP_CEILING:
<a name="l02816"></a>02816 x=car(sc-&gt;args);
<a name="l02817"></a>02817 s_return(sc, mk_real(sc, ceil(rvalue(x))));
<a name="l02818"></a>02818
<a name="l02819"></a>02819 <span class="keywordflow">case</span> OP_TRUNCATE : {
<a name="l02820"></a>02820 <span class="keywordtype">double</span> rvalue_of_x ;
<a name="l02821"></a>02821 x=car(sc-&gt;args);
<a name="l02822"></a>02822 rvalue_of_x = rvalue(x) ;
<a name="l02823"></a>02823 <span class="keywordflow">if</span> (rvalue_of_x &gt; 0) {
<a name="l02824"></a>02824 s_return(sc, mk_real(sc, floor(rvalue_of_x)));
<a name="l02825"></a>02825 } <span class="keywordflow">else</span> {
<a name="l02826"></a>02826 s_return(sc, mk_real(sc, ceil(rvalue_of_x)));
<a name="l02827"></a>02827 }
<a name="l02828"></a>02828 }
<a name="l02829"></a>02829
<a name="l02830"></a>02830 <span class="keywordflow">case</span> OP_ROUND:
<a name="l02831"></a>02831 x=car(sc-&gt;args);
<a name="l02832"></a>02832 s_return(sc, mk_real(sc, round_per_R5RS(rvalue(x))));
<a name="l02833"></a>02833 <span class="preprocessor">#endif</span>
<a name="l02834"></a>02834 <span class="preprocessor"></span>
<a name="l02835"></a>02835 <span class="keywordflow">case</span> OP_ADD: <span class="comment">/* + */</span>
<a name="l02836"></a>02836 v=num_zero;
<a name="l02837"></a>02837 <span class="keywordflow">for</span> (x = sc-&gt;args; x != sc-&gt;NIL; x = cdr(x)) {
<a name="l02838"></a>02838 v=num_add(v,nvalue(car(x)));
<a name="l02839"></a>02839 }
<a name="l02840"></a>02840 s_return(sc,mk_number(sc, v));
<a name="l02841"></a>02841
<a name="l02842"></a>02842 <span class="keywordflow">case</span> OP_MUL: <span class="comment">/* * */</span>
<a name="l02843"></a>02843 v=num_one;
<a name="l02844"></a>02844 <span class="keywordflow">for</span> (x = sc-&gt;args; x != sc-&gt;NIL; x = cdr(x)) {
<a name="l02845"></a>02845 v=num_mul(v,nvalue(car(x)));
<a name="l02846"></a>02846 }
<a name="l02847"></a>02847 s_return(sc,mk_number(sc, v));
<a name="l02848"></a>02848
<a name="l02849"></a>02849 <span class="keywordflow">case</span> OP_SUB: <span class="comment">/* - */</span>
<a name="l02850"></a>02850 <span class="keywordflow">if</span>(cdr(sc-&gt;args)==sc-&gt;NIL) {
<a name="l02851"></a>02851 x=sc-&gt;args;
<a name="l02852"></a>02852 v=num_zero;
<a name="l02853"></a>02853 } <span class="keywordflow">else</span> {
<a name="l02854"></a>02854 x = cdr(sc-&gt;args);
<a name="l02855"></a>02855 v = nvalue(car(sc-&gt;args));
<a name="l02856"></a>02856 }
<a name="l02857"></a>02857 <span class="keywordflow">for</span> (; x != sc-&gt;NIL; x = cdr(x)) {
<a name="l02858"></a>02858 v=num_sub(v,nvalue(car(x)));
<a name="l02859"></a>02859 }
<a name="l02860"></a>02860 s_return(sc,mk_number(sc, v));
<a name="l02861"></a>02861
<a name="l02862"></a>02862 <span class="keywordflow">case</span> OP_DIV: <span class="comment">/* / */</span>
<a name="l02863"></a>02863 <span class="keywordflow">if</span>(cdr(sc-&gt;args)==sc-&gt;NIL) {
<a name="l02864"></a>02864 x=sc-&gt;args;
<a name="l02865"></a>02865 v=num_one;
<a name="l02866"></a>02866 } <span class="keywordflow">else</span> {
<a name="l02867"></a>02867 x = cdr(sc-&gt;args);
<a name="l02868"></a>02868 v = nvalue(car(sc-&gt;args));
<a name="l02869"></a>02869 }
<a name="l02870"></a>02870 <span class="keywordflow">for</span> (; x != sc-&gt;NIL; x = cdr(x)) {
<a name="l02871"></a>02871 <span class="keywordflow">if</span> (!is_zero_double(rvalue(car(x))))
<a name="l02872"></a>02872 v=num_div(v,nvalue(car(x)));
<a name="l02873"></a>02873 <span class="keywordflow">else</span> {
<a name="l02874"></a>02874 Error_0(sc,<span class="stringliteral">"/: division by zero"</span>);
<a name="l02875"></a>02875 }
<a name="l02876"></a>02876 }
<a name="l02877"></a>02877 s_return(sc,mk_number(sc, v));
<a name="l02878"></a>02878
<a name="l02879"></a>02879 <span class="keywordflow">case</span> OP_INTDIV: <span class="comment">/* quotient */</span>
<a name="l02880"></a>02880 <span class="keywordflow">if</span>(cdr(sc-&gt;args)==sc-&gt;NIL) {
<a name="l02881"></a>02881 x=sc-&gt;args;
<a name="l02882"></a>02882 v=num_one;
<a name="l02883"></a>02883 } <span class="keywordflow">else</span> {
<a name="l02884"></a>02884 x = cdr(sc-&gt;args);
<a name="l02885"></a>02885 v = nvalue(car(sc-&gt;args));
<a name="l02886"></a>02886 }
<a name="l02887"></a>02887 <span class="keywordflow">for</span> (; x != sc-&gt;NIL; x = cdr(x)) {
<a name="l02888"></a>02888 <span class="keywordflow">if</span> (ivalue(car(x)) != 0)
<a name="l02889"></a>02889 v=num_intdiv(v,nvalue(car(x)));
<a name="l02890"></a>02890 <span class="keywordflow">else</span> {
<a name="l02891"></a>02891 Error_0(sc,<span class="stringliteral">"quotient: division by zero"</span>);
<a name="l02892"></a>02892 }
<a name="l02893"></a>02893 }
<a name="l02894"></a>02894 s_return(sc,mk_number(sc, v));
<a name="l02895"></a>02895
<a name="l02896"></a>02896 <span class="keywordflow">case</span> OP_REM: <span class="comment">/* remainder */</span>
<a name="l02897"></a>02897 v = nvalue(car(sc-&gt;args));
<a name="l02898"></a>02898 <span class="keywordflow">if</span> (ivalue(cadr(sc-&gt;args)) != 0)
<a name="l02899"></a>02899 v=num_rem(v,nvalue(cadr(sc-&gt;args)));
<a name="l02900"></a>02900 <span class="keywordflow">else</span> {
<a name="l02901"></a>02901 Error_0(sc,<span class="stringliteral">"remainder: division by zero"</span>);
<a name="l02902"></a>02902 }
<a name="l02903"></a>02903 s_return(sc,mk_number(sc, v));
<a name="l02904"></a>02904
<a name="l02905"></a>02905 <span class="keywordflow">case</span> OP_MOD: <span class="comment">/* modulo */</span>
<a name="l02906"></a>02906 v = nvalue(car(sc-&gt;args));
<a name="l02907"></a>02907 <span class="keywordflow">if</span> (ivalue(cadr(sc-&gt;args)) != 0)
<a name="l02908"></a>02908 v=num_mod(v,nvalue(cadr(sc-&gt;args)));
<a name="l02909"></a>02909 <span class="keywordflow">else</span> {
<a name="l02910"></a>02910 Error_0(sc,<span class="stringliteral">"modulo: division by zero"</span>);
<a name="l02911"></a>02911 }
<a name="l02912"></a>02912 s_return(sc,mk_number(sc, v));
<a name="l02913"></a>02913
<a name="l02914"></a>02914 <span class="keywordflow">case</span> OP_CAR: <span class="comment">/* car */</span>
<a name="l02915"></a>02915 s_return(sc,caar(sc-&gt;args));
<a name="l02916"></a>02916
<a name="l02917"></a>02917 <span class="keywordflow">case</span> OP_CDR: <span class="comment">/* cdr */</span>
<a name="l02918"></a>02918 s_return(sc,cdar(sc-&gt;args));
<a name="l02919"></a>02919
<a name="l02920"></a>02920 <span class="keywordflow">case</span> OP_CONS: <span class="comment">/* cons */</span>
<a name="l02921"></a>02921 cdr(sc-&gt;args) = cadr(sc-&gt;args);
<a name="l02922"></a>02922 s_return(sc,sc-&gt;args);
<a name="l02923"></a>02923
<a name="l02924"></a>02924 <span class="keywordflow">case</span> OP_SETCAR: <span class="comment">/* set-car! */</span>
<a name="l02925"></a>02925 <span class="keywordflow">if</span>(!is_immutable(car(sc-&gt;args))) {
<a name="l02926"></a>02926 caar(sc-&gt;args) = cadr(sc-&gt;args);
<a name="l02927"></a>02927 s_return(sc,car(sc-&gt;args));
<a name="l02928"></a>02928 } <span class="keywordflow">else</span> {
<a name="l02929"></a>02929 Error_0(sc,<span class="stringliteral">"set-car!: unable to alter immutable pair"</span>);
<a name="l02930"></a>02930 }
<a name="l02931"></a>02931
<a name="l02932"></a>02932 <span class="keywordflow">case</span> OP_SETCDR: <span class="comment">/* set-cdr! */</span>
<a name="l02933"></a>02933 <span class="keywordflow">if</span>(!is_immutable(car(sc-&gt;args))) {
<a name="l02934"></a>02934 cdar(sc-&gt;args) = cadr(sc-&gt;args);
<a name="l02935"></a>02935 s_return(sc,car(sc-&gt;args));
<a name="l02936"></a>02936 } <span class="keywordflow">else</span> {
<a name="l02937"></a>02937 Error_0(sc,<span class="stringliteral">"set-cdr!: unable to alter immutable pair"</span>);
<a name="l02938"></a>02938 }
<a name="l02939"></a>02939
<a name="l02940"></a>02940 <span class="keywordflow">case</span> OP_CHAR2INT: { <span class="comment">/* char-&gt;integer */</span>
<a name="l02941"></a>02941 <span class="keywordtype">char</span> c;
<a name="l02942"></a>02942 c=(char)ivalue(car(sc-&gt;args));
<a name="l02943"></a>02943 s_return(sc,mk_integer(sc,(<span class="keywordtype">unsigned</span> <span class="keywordtype">char</span>)c));
<a name="l02944"></a>02944 }
<a name="l02945"></a>02945
<a name="l02946"></a>02946 <span class="keywordflow">case</span> OP_INT2CHAR: { <span class="comment">/* integer-&gt;char */</span>
<a name="l02947"></a>02947 <span class="keywordtype">unsigned</span> <span class="keywordtype">char</span> c;
<a name="l02948"></a>02948 c=(<span class="keywordtype">unsigned</span> char)ivalue(car(sc-&gt;args));
<a name="l02949"></a>02949 s_return(sc,mk_character(sc,(<span class="keywordtype">char</span>)c));
<a name="l02950"></a>02950 }
<a name="l02951"></a>02951
<a name="l02952"></a>02952 <span class="keywordflow">case</span> OP_CHARUPCASE: {
<a name="l02953"></a>02953 <span class="keywordtype">unsigned</span> <span class="keywordtype">char</span> c;
<a name="l02954"></a>02954 c=(<span class="keywordtype">unsigned</span> char)ivalue(car(sc-&gt;args));
<a name="l02955"></a>02955 c=toupper(c);
<a name="l02956"></a>02956 s_return(sc,mk_character(sc,(<span class="keywordtype">char</span>)c));
<a name="l02957"></a>02957 }
<a name="l02958"></a>02958
<a name="l02959"></a>02959 <span class="keywordflow">case</span> OP_CHARDNCASE: {
<a name="l02960"></a>02960 <span class="keywordtype">unsigned</span> <span class="keywordtype">char</span> c;
<a name="l02961"></a>02961 c=(<span class="keywordtype">unsigned</span> char)ivalue(car(sc-&gt;args));
<a name="l02962"></a>02962 c=tolower(c);
<a name="l02963"></a>02963 s_return(sc,mk_character(sc,(<span class="keywordtype">char</span>)c));
<a name="l02964"></a>02964 }
<a name="l02965"></a>02965
<a name="l02966"></a>02966 <span class="keywordflow">case</span> OP_STR2SYM: <span class="comment">/* string-&gt;symbol */</span>
<a name="l02967"></a>02967 s_return(sc,mk_symbol(sc,strvalue(car(sc-&gt;args))));
<a name="l02968"></a>02968
<a name="l02969"></a>02969 <span class="keywordflow">case</span> OP_STR2ATOM: <span class="comment">/* string-&gt;atom */</span> {
<a name="l02970"></a>02970 <span class="keywordtype">char</span> *s=strvalue(car(sc-&gt;args));
<a name="l02971"></a>02971 <span class="keywordflow">if</span>(*s==<span class="charliteral">'#'</span>) {
<a name="l02972"></a>02972 s_return(sc, mk_sharp_const(sc, s+1));
<a name="l02973"></a>02973 } <span class="keywordflow">else</span> {
<a name="l02974"></a>02974 s_return(sc, mk_atom(sc, s));
<a name="l02975"></a>02975 }
<a name="l02976"></a>02976 }
<a name="l02977"></a>02977
<a name="l02978"></a>02978 <span class="keywordflow">case</span> OP_SYM2STR: <span class="comment">/* symbol-&gt;string */</span>
<a name="l02979"></a>02979 x=mk_string(sc,symname(car(sc-&gt;args)));
<a name="l02980"></a>02980 setimmutable(x);
<a name="l02981"></a>02981 s_return(sc,x);
<a name="l02982"></a>02982 <span class="keywordflow">case</span> OP_ATOM2STR: <span class="comment">/* atom-&gt;string */</span>
<a name="l02983"></a>02983 x=car(sc-&gt;args);
<a name="l02984"></a>02984 <span class="keywordflow">if</span>(is_number(x) || is_character(x) || is_string(x) || is_symbol(x)) {
<a name="l02985"></a>02985 <span class="keywordtype">char</span> *p;
<a name="l02986"></a>02986 <span class="keywordtype">int</span> len;
<a name="l02987"></a>02987 atom2str(sc,x,0,&amp;p,&amp;len);
<a name="l02988"></a>02988 s_return(sc,mk_counted_string(sc,p,len));
<a name="l02989"></a>02989 } <span class="keywordflow">else</span> {
<a name="l02990"></a>02990 Error_1(sc, <span class="stringliteral">"atom-&gt;string: not an atom:"</span>, x);
<a name="l02991"></a>02991 }
<a name="l02992"></a>02992
<a name="l02993"></a>02993 <span class="keywordflow">case</span> OP_MKSTRING: { <span class="comment">/* make-string */</span>
<a name="l02994"></a>02994 <span class="keywordtype">int</span> fill=<span class="charliteral">' '</span>;
<a name="l02995"></a>02995 <span class="keywordtype">int</span> len;
<a name="l02996"></a>02996
<a name="l02997"></a>02997 len=ivalue(car(sc-&gt;args));
<a name="l02998"></a>02998
<a name="l02999"></a>02999 <span class="keywordflow">if</span>(cdr(sc-&gt;args)!=sc-&gt;NIL) {
<a name="l03000"></a>03000 fill=charvalue(cadr(sc-&gt;args));
<a name="l03001"></a>03001 }
<a name="l03002"></a>03002 s_return(sc,mk_empty_string(sc,len,(<span class="keywordtype">char</span>)fill));
<a name="l03003"></a>03003 }
<a name="l03004"></a>03004
<a name="l03005"></a>03005 <span class="keywordflow">case</span> OP_STRLEN: <span class="comment">/* string-length */</span>
<a name="l03006"></a>03006 s_return(sc,mk_integer(sc,strlength(car(sc-&gt;args))));
<a name="l03007"></a>03007
<a name="l03008"></a>03008 <span class="keywordflow">case</span> OP_STRREF: { <span class="comment">/* string-ref */</span>
<a name="l03009"></a>03009 <span class="keywordtype">char</span> *str;
<a name="l03010"></a>03010 <span class="keywordtype">int</span> index;
<a name="l03011"></a>03011
<a name="l03012"></a>03012 str=strvalue(car(sc-&gt;args));
<a name="l03013"></a>03013
<a name="l03014"></a>03014 index=ivalue(cadr(sc-&gt;args));
<a name="l03015"></a>03015
<a name="l03016"></a>03016 <span class="keywordflow">if</span>(index&gt;=strlength(car(sc-&gt;args))) {
<a name="l03017"></a>03017 Error_1(sc,<span class="stringliteral">"string-ref: out of bounds:"</span>,cadr(sc-&gt;args));
<a name="l03018"></a>03018 }
<a name="l03019"></a>03019
<a name="l03020"></a>03020 s_return(sc,mk_character(sc,((<span class="keywordtype">unsigned</span> <span class="keywordtype">char</span>*)str)[index]));
<a name="l03021"></a>03021 }
<a name="l03022"></a>03022
<a name="l03023"></a>03023 <span class="keywordflow">case</span> OP_STRSET: { <span class="comment">/* string-set! */</span>
<a name="l03024"></a>03024 <span class="keywordtype">char</span> *str;
<a name="l03025"></a>03025 <span class="keywordtype">int</span> index;
<a name="l03026"></a>03026 <span class="keywordtype">int</span> c;
<a name="l03027"></a>03027
<a name="l03028"></a>03028 <span class="keywordflow">if</span>(is_immutable(car(sc-&gt;args))) {
<a name="l03029"></a>03029 Error_1(sc,<span class="stringliteral">"string-set!: unable to alter immutable string:"</span>,car(sc-&gt;args));
<a name="l03030"></a>03030 }
<a name="l03031"></a>03031 str=strvalue(car(sc-&gt;args));
<a name="l03032"></a>03032
<a name="l03033"></a>03033 index=ivalue(cadr(sc-&gt;args));
<a name="l03034"></a>03034 <span class="keywordflow">if</span>(index&gt;=strlength(car(sc-&gt;args))) {
<a name="l03035"></a>03035 Error_1(sc,<span class="stringliteral">"string-set!: out of bounds:"</span>,cadr(sc-&gt;args));
<a name="l03036"></a>03036 }
<a name="l03037"></a>03037
<a name="l03038"></a>03038 c=charvalue(caddr(sc-&gt;args));
<a name="l03039"></a>03039
<a name="l03040"></a>03040 str[index]=(char)c;
<a name="l03041"></a>03041 s_return(sc,car(sc-&gt;args));
<a name="l03042"></a>03042 }
<a name="l03043"></a>03043
<a name="l03044"></a>03044 <span class="keywordflow">case</span> OP_STRAPPEND: { <span class="comment">/* string-append */</span>
<a name="l03045"></a>03045 <span class="comment">/* in 1.29 string-append was in Scheme in init.scm but was too slow */</span>
<a name="l03046"></a>03046 <span class="keywordtype">int</span> len = 0;
<a name="l03047"></a>03047 pointer newstr;
<a name="l03048"></a>03048 <span class="keywordtype">char</span> *pos;
<a name="l03049"></a>03049
<a name="l03050"></a>03050 <span class="comment">/* compute needed length for new string */</span>
<a name="l03051"></a>03051 <span class="keywordflow">for</span> (x = sc-&gt;args; x != sc-&gt;NIL; x = cdr(x)) {
<a name="l03052"></a>03052 len += strlength(car(x));
<a name="l03053"></a>03053 }
<a name="l03054"></a>03054 newstr = mk_empty_string(sc, len, <span class="charliteral">' '</span>);
<a name="l03055"></a>03055 <span class="comment">/* store the contents of the argument strings into the new string */</span>
<a name="l03056"></a>03056 <span class="keywordflow">for</span> (pos = strvalue(newstr), x = sc-&gt;args; x != sc-&gt;NIL;
<a name="l03057"></a>03057 pos += strlength(car(x)), x = cdr(x)) {
<a name="l03058"></a>03058 memcpy(pos, strvalue(car(x)), strlength(car(x)));
<a name="l03059"></a>03059 }
<a name="l03060"></a>03060 s_return(sc, newstr);
<a name="l03061"></a>03061 }
<a name="l03062"></a>03062
<a name="l03063"></a>03063 <span class="keywordflow">case</span> OP_SUBSTR: { <span class="comment">/* substring */</span>
<a name="l03064"></a>03064 <span class="keywordtype">char</span> *str;
<a name="l03065"></a>03065 <span class="keywordtype">int</span> index0;
<a name="l03066"></a>03066 <span class="keywordtype">int</span> index1;
<a name="l03067"></a>03067 <span class="keywordtype">int</span> len;
<a name="l03068"></a>03068
<a name="l03069"></a>03069 str=strvalue(car(sc-&gt;args));
<a name="l03070"></a>03070
<a name="l03071"></a>03071 index0=ivalue(cadr(sc-&gt;args));
<a name="l03072"></a>03072
<a name="l03073"></a>03073 <span class="keywordflow">if</span>(index0&gt;strlength(car(sc-&gt;args))) {
<a name="l03074"></a>03074 Error_1(sc,<span class="stringliteral">"substring: start out of bounds:"</span>,cadr(sc-&gt;args));
<a name="l03075"></a>03075 }
<a name="l03076"></a>03076
<a name="l03077"></a>03077 <span class="keywordflow">if</span>(cddr(sc-&gt;args)!=sc-&gt;NIL) {
<a name="l03078"></a>03078 index1=ivalue(caddr(sc-&gt;args));
<a name="l03079"></a>03079 <span class="keywordflow">if</span>(index1&gt;strlength(car(sc-&gt;args)) || index1&lt;index0) {
<a name="l03080"></a>03080 Error_1(sc,<span class="stringliteral">"substring: end out of bounds:"</span>,caddr(sc-&gt;args));
<a name="l03081"></a>03081 }
<a name="l03082"></a>03082 } <span class="keywordflow">else</span> {
<a name="l03083"></a>03083 index1=strlength(car(sc-&gt;args));
<a name="l03084"></a>03084 }
<a name="l03085"></a>03085
<a name="l03086"></a>03086 len=index1-index0;
<a name="l03087"></a>03087 x=mk_empty_string(sc,len,<span class="charliteral">' '</span>);
<a name="l03088"></a>03088 memcpy(strvalue(x),str+index0,len);
<a name="l03089"></a>03089 strvalue(x)[len]=0;
<a name="l03090"></a>03090
<a name="l03091"></a>03091 s_return(sc,x);
<a name="l03092"></a>03092 }
<a name="l03093"></a>03093
<a name="l03094"></a>03094 <span class="keywordflow">case</span> OP_VECTOR: { <span class="comment">/* vector */</span>
<a name="l03095"></a>03095 <span class="keywordtype">int</span> i;
<a name="l03096"></a>03096 pointer vec;
<a name="l03097"></a>03097 <span class="keywordtype">int</span> len=list_length(sc,sc-&gt;args);
<a name="l03098"></a>03098 <span class="keywordflow">if</span>(len&lt;0) {
<a name="l03099"></a>03099 Error_1(sc,<span class="stringliteral">"vector: not a proper list:"</span>,sc-&gt;args);
<a name="l03100"></a>03100 }
<a name="l03101"></a>03101 vec=mk_vector(sc,len);
<a name="l03102"></a>03102 <span class="keywordflow">for</span> (x = sc-&gt;args, i = 0; is_pair(x); x = cdr(x), i++) {
<a name="l03103"></a>03103 set_vector_elem(vec,i,car(x));
<a name="l03104"></a>03104 }
<a name="l03105"></a>03105 s_return(sc,vec);
<a name="l03106"></a>03106 }
<a name="l03107"></a>03107
<a name="l03108"></a>03108 <span class="keywordflow">case</span> OP_MKVECTOR: { <span class="comment">/* make-vector */</span>
<a name="l03109"></a>03109 pointer fill=sc-&gt;NIL;
<a name="l03110"></a>03110 <span class="keywordtype">int</span> len;
<a name="l03111"></a>03111 pointer vec;
<a name="l03112"></a>03112
<a name="l03113"></a>03113 len=ivalue(car(sc-&gt;args));
<a name="l03114"></a>03114
<a name="l03115"></a>03115 <span class="keywordflow">if</span>(cdr(sc-&gt;args)!=sc-&gt;NIL) {
<a name="l03116"></a>03116 fill=cadr(sc-&gt;args);
<a name="l03117"></a>03117 }
<a name="l03118"></a>03118 vec=mk_vector(sc,len);
<a name="l03119"></a>03119 <span class="keywordflow">if</span>(fill!=sc-&gt;NIL) {
<a name="l03120"></a>03120 fill_vector(vec,fill);
<a name="l03121"></a>03121 }
<a name="l03122"></a>03122 s_return(sc,vec);
<a name="l03123"></a>03123 }
<a name="l03124"></a>03124
<a name="l03125"></a>03125 <span class="keywordflow">case</span> OP_VECLEN: <span class="comment">/* vector-length */</span>
<a name="l03126"></a>03126 s_return(sc,mk_integer(sc,ivalue(car(sc-&gt;args))));
<a name="l03127"></a>03127
<a name="l03128"></a>03128 <span class="keywordflow">case</span> OP_VECREF: { <span class="comment">/* vector-ref */</span>
<a name="l03129"></a>03129 <span class="keywordtype">int</span> index;
<a name="l03130"></a>03130
<a name="l03131"></a>03131 index=ivalue(cadr(sc-&gt;args));
<a name="l03132"></a>03132
<a name="l03133"></a>03133 <span class="keywordflow">if</span>(index&gt;=ivalue(car(sc-&gt;args))) {
<a name="l03134"></a>03134 Error_1(sc,<span class="stringliteral">"vector-ref: out of bounds:"</span>,cadr(sc-&gt;args));
<a name="l03135"></a>03135 }
<a name="l03136"></a>03136
<a name="l03137"></a>03137 s_return(sc,vector_elem(car(sc-&gt;args),index));
<a name="l03138"></a>03138 }
<a name="l03139"></a>03139
<a name="l03140"></a>03140 <span class="keywordflow">case</span> OP_VECSET: { <span class="comment">/* vector-set! */</span>
<a name="l03141"></a>03141 <span class="keywordtype">int</span> index;
<a name="l03142"></a>03142
<a name="l03143"></a>03143 <span class="keywordflow">if</span>(is_immutable(car(sc-&gt;args))) {
<a name="l03144"></a>03144 Error_1(sc,<span class="stringliteral">"vector-set!: unable to alter immutable vector:"</span>,car(sc-&gt;args));
<a name="l03145"></a>03145 }
<a name="l03146"></a>03146
<a name="l03147"></a>03147 index=ivalue(cadr(sc-&gt;args));
<a name="l03148"></a>03148 <span class="keywordflow">if</span>(index&gt;=ivalue(car(sc-&gt;args))) {
<a name="l03149"></a>03149 Error_1(sc,<span class="stringliteral">"vector-set!: out of bounds:"</span>,cadr(sc-&gt;args));
<a name="l03150"></a>03150 }
<a name="l03151"></a>03151
<a name="l03152"></a>03152 set_vector_elem(car(sc-&gt;args),index,caddr(sc-&gt;args));
<a name="l03153"></a>03153 s_return(sc,car(sc-&gt;args));
<a name="l03154"></a>03154 }
<a name="l03155"></a>03155
<a name="l03156"></a>03156 <span class="keywordflow">default</span>:
<a name="l03157"></a>03157 sprintf(sc-&gt;strbuff, <span class="stringliteral">"%d: illegal operator"</span>, sc-&gt;op);
<a name="l03158"></a>03158 Error_0(sc,sc-&gt;strbuff);
<a name="l03159"></a>03159 }
<a name="l03160"></a>03160 <span class="keywordflow">return</span> sc-&gt;T;
<a name="l03161"></a>03161 }
<a name="l03162"></a>03162
<a name="l03163"></a>03163 <span class="keyword">static</span> <span class="keywordtype">int</span> list_length(scheme *sc, pointer a) {
<a name="l03164"></a>03164 <span class="keywordtype">int</span> v=0;
<a name="l03165"></a>03165 pointer x;
<a name="l03166"></a>03166 <span class="keywordflow">for</span> (x = a, v = 0; is_pair(x); x = cdr(x)) {
<a name="l03167"></a>03167 ++v;
<a name="l03168"></a>03168 }
<a name="l03169"></a>03169 <span class="keywordflow">if</span>(x==sc-&gt;NIL) {
<a name="l03170"></a>03170 <span class="keywordflow">return</span> v;
<a name="l03171"></a>03171 }
<a name="l03172"></a>03172 <span class="keywordflow">return</span> -1;
<a name="l03173"></a>03173 }
<a name="l03174"></a>03174
<a name="l03175"></a>03175 <span class="keyword">static</span> pointer opexe_3(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op) {
<a name="l03176"></a>03176 pointer x;
<a name="l03177"></a>03177 num v;
<a name="l03178"></a>03178 int (*comp_func)(num,num)=0;
<a name="l03179"></a>03179
<a name="l03180"></a>03180 <span class="keywordflow">switch</span> (op) {
<a name="l03181"></a>03181 <span class="keywordflow">case</span> OP_NOT: <span class="comment">/* not */</span>
<a name="l03182"></a>03182 s_retbool(is_false(car(sc-&gt;args)));
<a name="l03183"></a>03183 <span class="keywordflow">case</span> OP_BOOLP: <span class="comment">/* boolean? */</span>
<a name="l03184"></a>03184 s_retbool(car(sc-&gt;args) == sc-&gt;F || car(sc-&gt;args) == sc-&gt;T);
<a name="l03185"></a>03185 <span class="keywordflow">case</span> OP_EOFOBJP: <span class="comment">/* boolean? */</span>
<a name="l03186"></a>03186 s_retbool(car(sc-&gt;args) == sc-&gt;EOF_OBJ);
<a name="l03187"></a>03187 <span class="keywordflow">case</span> OP_NULLP: <span class="comment">/* null? */</span>
<a name="l03188"></a>03188 s_retbool(car(sc-&gt;args) == sc-&gt;NIL);
<a name="l03189"></a>03189 <span class="keywordflow">case</span> OP_NUMEQ: <span class="comment">/* = */</span>
<a name="l03190"></a>03190 <span class="keywordflow">case</span> OP_LESS: <span class="comment">/* &lt; */</span>
<a name="l03191"></a>03191 <span class="keywordflow">case</span> OP_GRE: <span class="comment">/* &gt; */</span>
<a name="l03192"></a>03192 <span class="keywordflow">case</span> OP_LEQ: <span class="comment">/* &lt;= */</span>
<a name="l03193"></a>03193 <span class="keywordflow">case</span> OP_GEQ: <span class="comment">/* &gt;= */</span>
<a name="l03194"></a>03194 <span class="keywordflow">switch</span>(op) {
<a name="l03195"></a>03195 <span class="keywordflow">case</span> OP_NUMEQ: comp_func=num_eq; <span class="keywordflow">break</span>;
<a name="l03196"></a>03196 <span class="keywordflow">case</span> OP_LESS: comp_func=num_lt; <span class="keywordflow">break</span>;
<a name="l03197"></a>03197 <span class="keywordflow">case</span> OP_GRE: comp_func=num_gt; <span class="keywordflow">break</span>;
<a name="l03198"></a>03198 <span class="keywordflow">case</span> OP_LEQ: comp_func=num_le; <span class="keywordflow">break</span>;
<a name="l03199"></a>03199 <span class="keywordflow">case</span> OP_GEQ: comp_func=num_ge; <span class="keywordflow">break</span>;
<a name="l03200"></a>03200 <span class="keywordflow">default</span>:
<a name="l03201"></a>03201 ;
<a name="l03202"></a>03202 }
<a name="l03203"></a>03203 x=sc-&gt;args;
<a name="l03204"></a>03204 v=nvalue(car(x));
<a name="l03205"></a>03205 x=cdr(x);
<a name="l03206"></a>03206
<a name="l03207"></a>03207 <span class="keywordflow">for</span> (; x != sc-&gt;NIL; x = cdr(x)) {
<a name="l03208"></a>03208 <span class="keywordflow">if</span>(!comp_func(v,nvalue(car(x)))) {
<a name="l03209"></a>03209 s_retbool(0);
<a name="l03210"></a>03210 }
<a name="l03211"></a>03211 v=nvalue(car(x));
<a name="l03212"></a>03212 }
<a name="l03213"></a>03213 s_retbool(1);
<a name="l03214"></a>03214 <span class="keywordflow">case</span> OP_SYMBOLP: <span class="comment">/* symbol? */</span>
<a name="l03215"></a>03215 s_retbool(is_symbol(car(sc-&gt;args)));
<a name="l03216"></a>03216 <span class="keywordflow">case</span> OP_NUMBERP: <span class="comment">/* number? */</span>
<a name="l03217"></a>03217 s_retbool(is_number(car(sc-&gt;args)));
<a name="l03218"></a>03218 <span class="keywordflow">case</span> OP_STRINGP: <span class="comment">/* string? */</span>
<a name="l03219"></a>03219 s_retbool(is_string(car(sc-&gt;args)));
<a name="l03220"></a>03220 <span class="keywordflow">case</span> OP_INTEGERP: <span class="comment">/* integer? */</span>
<a name="l03221"></a>03221 s_retbool(is_integer(car(sc-&gt;args)));
<a name="l03222"></a>03222 <span class="keywordflow">case</span> OP_REALP: <span class="comment">/* real? */</span>
<a name="l03223"></a>03223 s_retbool(is_number(car(sc-&gt;args))); <span class="comment">/* All numbers are real */</span>
<a name="l03224"></a>03224 <span class="keywordflow">case</span> OP_CHARP: <span class="comment">/* char? */</span>
<a name="l03225"></a>03225 s_retbool(is_character(car(sc-&gt;args)));
<a name="l03226"></a>03226 <span class="preprocessor">#if USE_CHAR_CLASSIFIERS</span>
<a name="l03227"></a>03227 <span class="preprocessor"></span> <span class="keywordflow">case</span> OP_CHARAP: <span class="comment">/* char-alphabetic? */</span>
<a name="l03228"></a>03228 s_retbool(Cisalpha(ivalue(car(sc-&gt;args))));
<a name="l03229"></a>03229 <span class="keywordflow">case</span> OP_CHARNP: <span class="comment">/* char-numeric? */</span>
<a name="l03230"></a>03230 s_retbool(Cisdigit(ivalue(car(sc-&gt;args))));
<a name="l03231"></a>03231 <span class="keywordflow">case</span> OP_CHARWP: <span class="comment">/* char-whitespace? */</span>
<a name="l03232"></a>03232 s_retbool(Cisspace(ivalue(car(sc-&gt;args))));
<a name="l03233"></a>03233 <span class="keywordflow">case</span> OP_CHARUP: <span class="comment">/* char-upper-case? */</span>
<a name="l03234"></a>03234 s_retbool(Cisupper(ivalue(car(sc-&gt;args))));
<a name="l03235"></a>03235 <span class="keywordflow">case</span> OP_CHARLP: <span class="comment">/* char-lower-case? */</span>
<a name="l03236"></a>03236 s_retbool(Cislower(ivalue(car(sc-&gt;args))));
<a name="l03237"></a>03237 <span class="preprocessor">#endif</span>
<a name="l03238"></a>03238 <span class="preprocessor"></span> <span class="keywordflow">case</span> OP_PORTP: <span class="comment">/* port? */</span>
<a name="l03239"></a>03239 s_retbool(is_port(car(sc-&gt;args)));
<a name="l03240"></a>03240 <span class="keywordflow">case</span> OP_INPORTP: <span class="comment">/* input-port? */</span>
<a name="l03241"></a>03241 s_retbool(is_inport(car(sc-&gt;args)));
<a name="l03242"></a>03242 <span class="keywordflow">case</span> OP_OUTPORTP: <span class="comment">/* output-port? */</span>
<a name="l03243"></a>03243 s_retbool(is_outport(car(sc-&gt;args)));
<a name="l03244"></a>03244 <span class="keywordflow">case</span> OP_PROCP: <span class="comment">/* procedure? */</span>
<a name="l03245"></a>03245 <span class="comment">/*--</span>
<a name="l03246"></a>03246 <span class="comment"> * continuation should be procedure by the example</span>
<a name="l03247"></a>03247 <span class="comment"> * (call-with-current-continuation procedure?) ==&gt; #t</span>
<a name="l03248"></a>03248 <span class="comment"> * in R^3 report sec. 6.9</span>
<a name="l03249"></a>03249 <span class="comment"> */</span>
<a name="l03250"></a>03250 s_retbool(is_proc(car(sc-&gt;args)) || is_closure(car(sc-&gt;args))
<a name="l03251"></a>03251 || is_continuation(car(sc-&gt;args)) || is_foreign(car(sc-&gt;args)));
<a name="l03252"></a>03252 <span class="keywordflow">case</span> OP_PAIRP: <span class="comment">/* pair? */</span>
<a name="l03253"></a>03253 s_retbool(is_pair(car(sc-&gt;args)));
<a name="l03254"></a>03254 <span class="keywordflow">case</span> OP_LISTP: { <span class="comment">/* list? */</span>
<a name="l03255"></a>03255 pointer slow, fast;
<a name="l03256"></a>03256 slow = fast = car(sc-&gt;args);
<a name="l03257"></a>03257 <span class="keywordflow">while</span> (1) {
<a name="l03258"></a>03258 <span class="keywordflow">if</span> (!is_pair(fast)) s_retbool(fast == sc-&gt;NIL);
<a name="l03259"></a>03259 fast = cdr(fast);
<a name="l03260"></a>03260 <span class="keywordflow">if</span> (!is_pair(fast)) s_retbool(fast == sc-&gt;NIL);
<a name="l03261"></a>03261 fast = cdr(fast);
<a name="l03262"></a>03262 slow = cdr(slow);
<a name="l03263"></a>03263 <span class="keywordflow">if</span> (fast == slow) {
<a name="l03264"></a>03264 <span class="comment">/* the fast pointer has looped back around and caught up</span>
<a name="l03265"></a>03265 <span class="comment"> with the slow pointer, hence the structure is circular,</span>
<a name="l03266"></a>03266 <span class="comment"> not of finite length, and therefore not a list */</span>
<a name="l03267"></a>03267 s_retbool(0);
<a name="l03268"></a>03268 }
<a name="l03269"></a>03269 }
<a name="l03270"></a>03270 }
<a name="l03271"></a>03271 <span class="keywordflow">case</span> OP_ENVP: <span class="comment">/* environment? */</span>
<a name="l03272"></a>03272 s_retbool(is_environment(car(sc-&gt;args)));
<a name="l03273"></a>03273 <span class="keywordflow">case</span> OP_VECTORP: <span class="comment">/* vector? */</span>
<a name="l03274"></a>03274 s_retbool(is_vector(car(sc-&gt;args)));
<a name="l03275"></a>03275 <span class="keywordflow">case</span> OP_EQ: <span class="comment">/* eq? */</span>
<a name="l03276"></a>03276 s_retbool(car(sc-&gt;args) == cadr(sc-&gt;args));
<a name="l03277"></a>03277 <span class="keywordflow">case</span> OP_EQV: <span class="comment">/* eqv? */</span>
<a name="l03278"></a>03278 s_retbool(eqv(car(sc-&gt;args), cadr(sc-&gt;args)));
<a name="l03279"></a>03279 <span class="keywordflow">default</span>:
<a name="l03280"></a>03280 sprintf(sc-&gt;strbuff, <span class="stringliteral">"%d: illegal operator"</span>, sc-&gt;op);
<a name="l03281"></a>03281 Error_0(sc,sc-&gt;strbuff);
<a name="l03282"></a>03282 }
<a name="l03283"></a>03283 <span class="keywordflow">return</span> sc-&gt;T;
<a name="l03284"></a>03284 }
<a name="l03285"></a>03285
<a name="l03286"></a>03286 <span class="keyword">static</span> pointer opexe_4(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op) {
<a name="l03287"></a>03287 pointer x, y;
<a name="l03288"></a>03288
<a name="l03289"></a>03289 <span class="keywordflow">switch</span> (op) {
<a name="l03290"></a>03290 <span class="keywordflow">case</span> OP_FORCE: <span class="comment">/* force */</span>
<a name="l03291"></a>03291 sc-&gt;code = car(sc-&gt;args);
<a name="l03292"></a>03292 <span class="keywordflow">if</span> (is_promise(sc-&gt;code)) {
<a name="l03293"></a>03293 <span class="comment">/* Should change type to closure here */</span>
<a name="l03294"></a>03294 s_save(sc, OP_SAVE_FORCED, sc-&gt;NIL, sc-&gt;code);
<a name="l03295"></a>03295 sc-&gt;args = sc-&gt;NIL;
<a name="l03296"></a>03296 s_goto(sc,OP_APPLY);
<a name="l03297"></a>03297 } <span class="keywordflow">else</span> {
<a name="l03298"></a>03298 s_return(sc,sc-&gt;code);
<a name="l03299"></a>03299 }
<a name="l03300"></a>03300
<a name="l03301"></a>03301 <span class="keywordflow">case</span> OP_SAVE_FORCED: <span class="comment">/* Save forced value replacing promise */</span>
<a name="l03302"></a>03302 memcpy(sc-&gt;code,sc-&gt;value,<span class="keyword">sizeof</span>(<span class="keyword">struct</span> cell));
<a name="l03303"></a>03303 s_return(sc,sc-&gt;value);
<a name="l03304"></a>03304
<a name="l03305"></a>03305 <span class="keywordflow">case</span> OP_WRITE: <span class="comment">/* write */</span>
<a name="l03306"></a>03306 <span class="keywordflow">case</span> OP_DISPLAY: <span class="comment">/* display */</span>
<a name="l03307"></a>03307 <span class="keywordflow">case</span> OP_WRITE_CHAR: <span class="comment">/* write-char */</span>
<a name="l03308"></a>03308 <span class="keywordflow">if</span>(is_pair(cdr(sc-&gt;args))) {
<a name="l03309"></a>03309 <span class="keywordflow">if</span>(cadr(sc-&gt;args)!=sc-&gt;outport) {
<a name="l03310"></a>03310 x=cons(sc,sc-&gt;outport,sc-&gt;NIL);
<a name="l03311"></a>03311 s_save(sc,OP_SET_OUTPORT, x, sc-&gt;NIL);
<a name="l03312"></a>03312 sc-&gt;outport=cadr(sc-&gt;args);
<a name="l03313"></a>03313 }
<a name="l03314"></a>03314 }
<a name="l03315"></a>03315 sc-&gt;args = car(sc-&gt;args);
<a name="l03316"></a>03316 <span class="keywordflow">if</span>(op==OP_WRITE) {
<a name="l03317"></a>03317 sc-&gt;print_flag = 1;
<a name="l03318"></a>03318 } <span class="keywordflow">else</span> {
<a name="l03319"></a>03319 sc-&gt;print_flag = 0;
<a name="l03320"></a>03320 }
<a name="l03321"></a>03321 s_goto(sc,OP_P0LIST);
<a name="l03322"></a>03322
<a name="l03323"></a>03323 <span class="keywordflow">case</span> OP_NEWLINE: <span class="comment">/* newline */</span>
<a name="l03324"></a>03324 <span class="keywordflow">if</span>(is_pair(sc-&gt;args)) {
<a name="l03325"></a>03325 <span class="keywordflow">if</span>(car(sc-&gt;args)!=sc-&gt;outport) {
<a name="l03326"></a>03326 x=cons(sc,sc-&gt;outport,sc-&gt;NIL);
<a name="l03327"></a>03327 s_save(sc,OP_SET_OUTPORT, x, sc-&gt;NIL);
<a name="l03328"></a>03328 sc-&gt;outport=car(sc-&gt;args);
<a name="l03329"></a>03329 }
<a name="l03330"></a>03330 }
<a name="l03331"></a>03331 putstr(sc, <span class="stringliteral">"\n"</span>);
<a name="l03332"></a>03332 s_return(sc,sc-&gt;T);
<a name="l03333"></a>03333
<a name="l03334"></a>03334 <span class="keywordflow">case</span> OP_ERR0: <span class="comment">/* error */</span>
<a name="l03335"></a>03335 sc-&gt;retcode=-1;
<a name="l03336"></a>03336 <span class="keywordflow">if</span> (!is_string(car(sc-&gt;args))) {
<a name="l03337"></a>03337 sc-&gt;args=cons(sc,mk_string(sc,<span class="stringliteral">" -- "</span>),sc-&gt;args);
<a name="l03338"></a>03338 setimmutable(car(sc-&gt;args));
<a name="l03339"></a>03339 }
<a name="l03340"></a>03340 putstr(sc, <span class="stringliteral">"Error: "</span>);
<a name="l03341"></a>03341 putstr(sc, strvalue(car(sc-&gt;args)));
<a name="l03342"></a>03342 sc-&gt;args = cdr(sc-&gt;args);
<a name="l03343"></a>03343 s_goto(sc,OP_ERR1);
<a name="l03344"></a>03344
<a name="l03345"></a>03345 <span class="keywordflow">case</span> OP_ERR1: <span class="comment">/* error */</span>
<a name="l03346"></a>03346 putstr(sc, <span class="stringliteral">" "</span>);
<a name="l03347"></a>03347 <span class="keywordflow">if</span> (sc-&gt;args != sc-&gt;NIL) {
<a name="l03348"></a>03348 s_save(sc,OP_ERR1, cdr(sc-&gt;args), sc-&gt;NIL);
<a name="l03349"></a>03349 sc-&gt;args = car(sc-&gt;args);
<a name="l03350"></a>03350 sc-&gt;print_flag = 1;
<a name="l03351"></a>03351 s_goto(sc,OP_P0LIST);
<a name="l03352"></a>03352 } <span class="keywordflow">else</span> {
<a name="l03353"></a>03353 putstr(sc, <span class="stringliteral">"\n"</span>);
<a name="l03354"></a>03354 <span class="keywordflow">if</span>(sc-&gt;interactive_repl) {
<a name="l03355"></a>03355 s_goto(sc,OP_T0LVL);
<a name="l03356"></a>03356 } <span class="keywordflow">else</span> {
<a name="l03357"></a>03357 <span class="keywordflow">return</span> sc-&gt;NIL;
<a name="l03358"></a>03358 }
<a name="l03359"></a>03359 }
<a name="l03360"></a>03360
<a name="l03361"></a>03361 <span class="keywordflow">case</span> OP_REVERSE: <span class="comment">/* reverse */</span>
<a name="l03362"></a>03362 s_return(sc,reverse(sc, car(sc-&gt;args)));
<a name="l03363"></a>03363
<a name="l03364"></a>03364 <span class="keywordflow">case</span> OP_LIST_STAR: <span class="comment">/* list* */</span>
<a name="l03365"></a>03365 s_return(sc,list_star(sc,sc-&gt;args));
<a name="l03366"></a>03366
<a name="l03367"></a>03367 <span class="keywordflow">case</span> OP_APPEND: <span class="comment">/* append */</span>
<a name="l03368"></a>03368 <span class="keywordflow">if</span>(sc-&gt;args==sc-&gt;NIL) {
<a name="l03369"></a>03369 s_return(sc,sc-&gt;NIL);
<a name="l03370"></a>03370 }
<a name="l03371"></a>03371 x=car(sc-&gt;args);
<a name="l03372"></a>03372 <span class="keywordflow">if</span>(cdr(sc-&gt;args)==sc-&gt;NIL) {
<a name="l03373"></a>03373 s_return(sc,sc-&gt;args);
<a name="l03374"></a>03374 }
<a name="l03375"></a>03375 <span class="keywordflow">for</span> (y = cdr(sc-&gt;args); y != sc-&gt;NIL; y = cdr(y)) {
<a name="l03376"></a>03376 x=append(sc,x,car(y));
<a name="l03377"></a>03377 }
<a name="l03378"></a>03378 s_return(sc,x);
<a name="l03379"></a>03379
<a name="l03380"></a>03380 <span class="preprocessor">#if USE_PLIST</span>
<a name="l03381"></a>03381 <span class="preprocessor"></span> <span class="keywordflow">case</span> OP_PUT: <span class="comment">/* put */</span>
<a name="l03382"></a>03382 <span class="keywordflow">if</span> (!hasprop(car(sc-&gt;args)) || !hasprop(cadr(sc-&gt;args))) {
<a name="l03383"></a>03383 Error_0(sc,<span class="stringliteral">"illegal use of put"</span>);
<a name="l03384"></a>03384 }
<a name="l03385"></a>03385 <span class="keywordflow">for</span> (x = symprop(car(sc-&gt;args)), y = cadr(sc-&gt;args); x != sc-&gt;NIL; x = cdr(x)) {
<a name="l03386"></a>03386 <span class="keywordflow">if</span> (caar(x) == y) {
<a name="l03387"></a>03387 <span class="keywordflow">break</span>;
<a name="l03388"></a>03388 }
<a name="l03389"></a>03389 }
<a name="l03390"></a>03390 <span class="keywordflow">if</span> (x != sc-&gt;NIL)
<a name="l03391"></a>03391 cdar(x) = caddr(sc-&gt;args);
<a name="l03392"></a>03392 <span class="keywordflow">else</span>
<a name="l03393"></a>03393 symprop(car(sc-&gt;args)) = cons(sc, cons(sc, y, caddr(sc-&gt;args)),
<a name="l03394"></a>03394 symprop(car(sc-&gt;args)));
<a name="l03395"></a>03395 s_return(sc,sc-&gt;T);
<a name="l03396"></a>03396
<a name="l03397"></a>03397 <span class="keywordflow">case</span> OP_GET: <span class="comment">/* get */</span>
<a name="l03398"></a>03398 <span class="keywordflow">if</span> (!hasprop(car(sc-&gt;args)) || !hasprop(cadr(sc-&gt;args))) {
<a name="l03399"></a>03399 Error_0(sc,<span class="stringliteral">"illegal use of get"</span>);
<a name="l03400"></a>03400 }
<a name="l03401"></a>03401 <span class="keywordflow">for</span> (x = symprop(car(sc-&gt;args)), y = cadr(sc-&gt;args); x != sc-&gt;NIL; x = cdr(x)) {
<a name="l03402"></a>03402 <span class="keywordflow">if</span> (caar(x) == y) {
<a name="l03403"></a>03403 <span class="keywordflow">break</span>;
<a name="l03404"></a>03404 }
<a name="l03405"></a>03405 }
<a name="l03406"></a>03406 <span class="keywordflow">if</span> (x != sc-&gt;NIL) {
<a name="l03407"></a>03407 s_return(sc,cdar(x));
<a name="l03408"></a>03408 } <span class="keywordflow">else</span> {
<a name="l03409"></a>03409 s_return(sc,sc-&gt;NIL);
<a name="l03410"></a>03410 }
<a name="l03411"></a>03411 <span class="preprocessor">#endif </span><span class="comment">/* USE_PLIST */</span>
<a name="l03412"></a>03412 <span class="keywordflow">case</span> OP_QUIT: <span class="comment">/* quit */</span>
<a name="l03413"></a>03413 <span class="keywordflow">if</span>(is_pair(sc-&gt;args)) {
<a name="l03414"></a>03414 sc-&gt;retcode=ivalue(car(sc-&gt;args));
<a name="l03415"></a>03415 }
<a name="l03416"></a>03416 <span class="keywordflow">return</span> (sc-&gt;NIL);
<a name="l03417"></a>03417
<a name="l03418"></a>03418 <span class="keywordflow">case</span> OP_GC: <span class="comment">/* gc */</span>
<a name="l03419"></a>03419 gc(sc, sc-&gt;NIL, sc-&gt;NIL);
<a name="l03420"></a>03420 s_return(sc,sc-&gt;T);
<a name="l03421"></a>03421
<a name="l03422"></a>03422 <span class="keywordflow">case</span> OP_GCVERB: <span class="comment">/* gc-verbose */</span>
<a name="l03423"></a>03423 { <span class="keywordtype">int</span> was = sc-&gt;gc_verbose;
<a name="l03424"></a>03424
<a name="l03425"></a>03425 sc-&gt;gc_verbose = (car(sc-&gt;args) != sc-&gt;F);
<a name="l03426"></a>03426 s_retbool(was);
<a name="l03427"></a>03427 }
<a name="l03428"></a>03428
<a name="l03429"></a>03429 <span class="keywordflow">case</span> OP_NEWSEGMENT: <span class="comment">/* new-segment */</span>
<a name="l03430"></a>03430 <span class="keywordflow">if</span> (!is_pair(sc-&gt;args) || !is_number(car(sc-&gt;args))) {
<a name="l03431"></a>03431 Error_0(sc,<span class="stringliteral">"new-segment: argument must be a number"</span>);
<a name="l03432"></a>03432 }
<a name="l03433"></a>03433 alloc_cellseg(sc, (<span class="keywordtype">int</span>) ivalue(car(sc-&gt;args)));
<a name="l03434"></a>03434 s_return(sc,sc-&gt;T);
<a name="l03435"></a>03435
<a name="l03436"></a>03436 <span class="keywordflow">case</span> OP_OBLIST: <span class="comment">/* oblist */</span>
<a name="l03437"></a>03437 s_return(sc, oblist_all_symbols(sc));
<a name="l03438"></a>03438
<a name="l03439"></a>03439 <span class="keywordflow">case</span> OP_CURR_INPORT: <span class="comment">/* current-input-port */</span>
<a name="l03440"></a>03440 s_return(sc,sc-&gt;inport);
<a name="l03441"></a>03441
<a name="l03442"></a>03442 <span class="keywordflow">case</span> OP_CURR_OUTPORT: <span class="comment">/* current-output-port */</span>
<a name="l03443"></a>03443 s_return(sc,sc-&gt;outport);
<a name="l03444"></a>03444
<a name="l03445"></a>03445 <span class="keywordflow">case</span> OP_OPEN_INFILE: <span class="comment">/* open-input-file */</span>
<a name="l03446"></a>03446 <span class="keywordflow">case</span> OP_OPEN_OUTFILE: <span class="comment">/* open-output-file */</span>
<a name="l03447"></a>03447 <span class="keywordflow">case</span> OP_OPEN_INOUTFILE: <span class="comment">/* open-input-output-file */</span> {
<a name="l03448"></a>03448 <span class="keywordtype">int</span> prop=0;
<a name="l03449"></a>03449 pointer p;
<a name="l03450"></a>03450 <span class="keywordflow">switch</span>(op) {
<a name="l03451"></a>03451 <span class="keywordflow">case</span> OP_OPEN_INFILE: prop=port_input; <span class="keywordflow">break</span>;
<a name="l03452"></a>03452 <span class="keywordflow">case</span> OP_OPEN_OUTFILE: prop=port_output; <span class="keywordflow">break</span>;
<a name="l03453"></a>03453 <span class="keywordflow">case</span> OP_OPEN_INOUTFILE: prop=port_input|port_output; <span class="keywordflow">break</span>;
<a name="l03454"></a>03454 <span class="keywordflow">default</span>:
<a name="l03455"></a>03455 ;
<a name="l03456"></a>03456 }
<a name="l03457"></a>03457 p=port_from_filename(sc,strvalue(car(sc-&gt;args)),prop);
<a name="l03458"></a>03458 <span class="keywordflow">if</span>(p==sc-&gt;NIL) {
<a name="l03459"></a>03459 s_return(sc,sc-&gt;F);
<a name="l03460"></a>03460 }
<a name="l03461"></a>03461 s_return(sc,p);
<a name="l03462"></a>03462 }
<a name="l03463"></a>03463
<a name="l03464"></a>03464 <span class="preprocessor">#if USE_STRING_PORTS</span>
<a name="l03465"></a>03465 <span class="preprocessor"></span> <span class="keywordflow">case</span> OP_OPEN_INSTRING: <span class="comment">/* open-input-string */</span>
<a name="l03466"></a>03466 <span class="keywordflow">case</span> OP_OPEN_OUTSTRING: <span class="comment">/* open-output-string */</span>
<a name="l03467"></a>03467 <span class="keywordflow">case</span> OP_OPEN_INOUTSTRING: <span class="comment">/* open-input-output-string */</span> {
<a name="l03468"></a>03468 <span class="keywordtype">int</span> prop=0;
<a name="l03469"></a>03469 pointer p;
<a name="l03470"></a>03470 <span class="keywordflow">switch</span>(op) {
<a name="l03471"></a>03471 <span class="keywordflow">case</span> OP_OPEN_INSTRING: prop=port_input; <span class="keywordflow">break</span>;
<a name="l03472"></a>03472 <span class="keywordflow">case</span> OP_OPEN_OUTSTRING: prop=port_output; <span class="keywordflow">break</span>;
<a name="l03473"></a>03473 <span class="keywordflow">case</span> OP_OPEN_INOUTSTRING: prop=port_input|port_output; <span class="keywordflow">break</span>;
<a name="l03474"></a>03474 <span class="keywordflow">default</span>:
<a name="l03475"></a>03475 ;
<a name="l03476"></a>03476 }
<a name="l03477"></a>03477 p=port_from_string(sc, strvalue(car(sc-&gt;args)),
<a name="l03478"></a>03478 strvalue(car(sc-&gt;args))+strlength(car(sc-&gt;args)), prop);
<a name="l03479"></a>03479 <span class="keywordflow">if</span>(p==sc-&gt;NIL) {
<a name="l03480"></a>03480 s_return(sc,sc-&gt;F);
<a name="l03481"></a>03481 }
<a name="l03482"></a>03482 s_return(sc,p);
<a name="l03483"></a>03483 }
<a name="l03484"></a>03484 <span class="preprocessor">#endif</span>
<a name="l03485"></a>03485 <span class="preprocessor"></span>
<a name="l03486"></a>03486 <span class="keywordflow">case</span> OP_CLOSE_INPORT: <span class="comment">/* close-input-port */</span>
<a name="l03487"></a>03487 port_close(sc,car(sc-&gt;args),port_input);
<a name="l03488"></a>03488 s_return(sc,sc-&gt;T);
<a name="l03489"></a>03489
<a name="l03490"></a>03490 <span class="keywordflow">case</span> OP_CLOSE_OUTPORT: <span class="comment">/* close-output-port */</span>
<a name="l03491"></a>03491 port_close(sc,car(sc-&gt;args),port_output);
<a name="l03492"></a>03492 s_return(sc,sc-&gt;T);
<a name="l03493"></a>03493
<a name="l03494"></a>03494 <span class="keywordflow">case</span> OP_INT_ENV: <span class="comment">/* interaction-environment */</span>
<a name="l03495"></a>03495 s_return(sc,sc-&gt;global_env);
<a name="l03496"></a>03496
<a name="l03497"></a>03497 <span class="keywordflow">case</span> OP_CURR_ENV: <span class="comment">/* current-environment */</span>
<a name="l03498"></a>03498 s_return(sc,sc-&gt;envir);
<a name="l03499"></a>03499 <span class="keywordflow">default</span>:
<a name="l03500"></a>03500 ;
<a name="l03501"></a>03501 }
<a name="l03502"></a>03502 <span class="keywordflow">return</span> sc-&gt;T;
<a name="l03503"></a>03503 }
<a name="l03504"></a>03504
<a name="l03505"></a>03505 <span class="keyword">static</span> pointer opexe_5(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op) {
<a name="l03506"></a>03506 pointer x;
<a name="l03507"></a>03507
<a name="l03508"></a>03508 <span class="keywordflow">if</span>(sc-&gt;nesting!=0) {
<a name="l03509"></a>03509 <span class="keywordtype">int</span> n=sc-&gt;nesting;
<a name="l03510"></a>03510 sc-&gt;nesting=0;
<a name="l03511"></a>03511 sc-&gt;retcode=-1;
<a name="l03512"></a>03512 Error_1(sc,<span class="stringliteral">"unmatched parentheses:"</span>,mk_integer(sc,n));
<a name="l03513"></a>03513 }
<a name="l03514"></a>03514
<a name="l03515"></a>03515 <span class="keywordflow">switch</span> (op) {
<a name="l03516"></a>03516 <span class="comment">/* ========== reading part ========== */</span>
<a name="l03517"></a>03517 <span class="keywordflow">case</span> OP_READ:
<a name="l03518"></a>03518 <span class="keywordflow">if</span>(!is_pair(sc-&gt;args)) {
<a name="l03519"></a>03519 s_goto(sc,OP_READ_INTERNAL);
<a name="l03520"></a>03520 }
<a name="l03521"></a>03521 <span class="keywordflow">if</span>(!is_inport(car(sc-&gt;args))) {
<a name="l03522"></a>03522 Error_1(sc,<span class="stringliteral">"read: not an input port:"</span>,car(sc-&gt;args));
<a name="l03523"></a>03523 }
<a name="l03524"></a>03524 <span class="keywordflow">if</span>(car(sc-&gt;args)==sc-&gt;inport) {
<a name="l03525"></a>03525 s_goto(sc,OP_READ_INTERNAL);
<a name="l03526"></a>03526 }
<a name="l03527"></a>03527 x=sc-&gt;inport;
<a name="l03528"></a>03528 sc-&gt;inport=car(sc-&gt;args);
<a name="l03529"></a>03529 x=cons(sc,x,sc-&gt;NIL);
<a name="l03530"></a>03530 s_save(sc,OP_SET_INPORT, x, sc-&gt;NIL);
<a name="l03531"></a>03531 s_goto(sc,OP_READ_INTERNAL);
<a name="l03532"></a>03532
<a name="l03533"></a>03533 <span class="keywordflow">case</span> OP_READ_CHAR: <span class="comment">/* read-char */</span>
<a name="l03534"></a>03534 <span class="keywordflow">case</span> OP_PEEK_CHAR: <span class="comment">/* peek-char */</span> {
<a name="l03535"></a>03535 <span class="keywordtype">int</span> c;
<a name="l03536"></a>03536 <span class="keywordflow">if</span>(is_pair(sc-&gt;args)) {
<a name="l03537"></a>03537 <span class="keywordflow">if</span>(car(sc-&gt;args)!=sc-&gt;inport) {
<a name="l03538"></a>03538 x=sc-&gt;inport;
<a name="l03539"></a>03539 x=cons(sc,x,sc-&gt;NIL);
<a name="l03540"></a>03540 s_save(sc,OP_SET_INPORT, x, sc-&gt;NIL);
<a name="l03541"></a>03541 sc-&gt;inport=car(sc-&gt;args);
<a name="l03542"></a>03542 }
<a name="l03543"></a>03543 }
<a name="l03544"></a>03544 c=inchar(sc);
<a name="l03545"></a>03545 <span class="keywordflow">if</span>(c==EOF) {
<a name="l03546"></a>03546 s_return(sc,sc-&gt;EOF_OBJ);
<a name="l03547"></a>03547 }
<a name="l03548"></a>03548 <span class="keywordflow">if</span>(sc-&gt;op==OP_PEEK_CHAR) {
<a name="l03549"></a>03549 backchar(sc,c);
<a name="l03550"></a>03550 }
<a name="l03551"></a>03551 s_return(sc,mk_character(sc,c));
<a name="l03552"></a>03552 }
<a name="l03553"></a>03553
<a name="l03554"></a>03554 <span class="keywordflow">case</span> OP_CHAR_READY: <span class="comment">/* char-ready? */</span> {
<a name="l03555"></a>03555 pointer p=sc-&gt;inport;
<a name="l03556"></a>03556 <span class="keywordtype">int</span> res;
<a name="l03557"></a>03557 <span class="keywordflow">if</span>(is_pair(sc-&gt;args)) {
<a name="l03558"></a>03558 p=car(sc-&gt;args);
<a name="l03559"></a>03559 }
<a name="l03560"></a>03560 res=p-&gt;_object._port-&gt;kind&amp;port_string;
<a name="l03561"></a>03561 s_retbool(res);
<a name="l03562"></a>03562 }
<a name="l03563"></a>03563
<a name="l03564"></a>03564 <span class="keywordflow">case</span> OP_SET_INPORT: <span class="comment">/* set-input-port */</span>
<a name="l03565"></a>03565 sc-&gt;inport=car(sc-&gt;args);
<a name="l03566"></a>03566 s_return(sc,sc-&gt;value);
<a name="l03567"></a>03567
<a name="l03568"></a>03568 <span class="keywordflow">case</span> OP_SET_OUTPORT: <span class="comment">/* set-output-port */</span>
<a name="l03569"></a>03569 sc-&gt;outport=car(sc-&gt;args);
<a name="l03570"></a>03570 s_return(sc,sc-&gt;value);
<a name="l03571"></a>03571
<a name="l03572"></a>03572 <span class="keywordflow">case</span> OP_RDSEXPR:
<a name="l03573"></a>03573 <span class="keywordflow">switch</span> (sc-&gt;tok) {
<a name="l03574"></a>03574 <span class="keywordflow">case</span> TOK_EOF:
<a name="l03575"></a>03575 <span class="keywordflow">if</span>(sc-&gt;inport==sc-&gt;loadport) {
<a name="l03576"></a>03576 sc-&gt;args=sc-&gt;NIL;
<a name="l03577"></a>03577 s_goto(sc,OP_QUIT);
<a name="l03578"></a>03578 } <span class="keywordflow">else</span> {
<a name="l03579"></a>03579 s_return(sc,sc-&gt;EOF_OBJ);
<a name="l03580"></a>03580 }
<a name="l03581"></a>03581 <span class="keywordflow">case</span> TOK_COMMENT: {
<a name="l03582"></a>03582 <span class="keywordtype">int</span> c;
<a name="l03583"></a>03583 <span class="keywordflow">while</span> ((c=inchar(sc)) != <span class="charliteral">'\n'</span> &amp;&amp; c!=EOF)
<a name="l03584"></a>03584 ;
<a name="l03585"></a>03585 sc-&gt;tok = token(sc);
<a name="l03586"></a>03586 s_goto(sc,OP_RDSEXPR);
<a name="l03587"></a>03587 }
<a name="l03588"></a>03588 <span class="keywordflow">case</span> TOK_VEC:
<a name="l03589"></a>03589 s_save(sc,OP_RDVEC,sc-&gt;NIL,sc-&gt;NIL);
<a name="l03590"></a>03590 <span class="comment">/* fall through */</span>
<a name="l03591"></a>03591 <span class="keywordflow">case</span> TOK_LPAREN:
<a name="l03592"></a>03592 sc-&gt;tok = token(sc);
<a name="l03593"></a>03593 <span class="keywordflow">if</span> (sc-&gt;tok == TOK_RPAREN) {
<a name="l03594"></a>03594 s_return(sc,sc-&gt;NIL);
<a name="l03595"></a>03595 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (sc-&gt;tok == TOK_DOT) {
<a name="l03596"></a>03596 Error_0(sc,<span class="stringliteral">"syntax error: illegal dot expression"</span>);
<a name="l03597"></a>03597 } <span class="keywordflow">else</span> {
<a name="l03598"></a>03598 sc-&gt;nesting_stack[sc-&gt;file_i]++;
<a name="l03599"></a>03599 s_save(sc,OP_RDLIST, sc-&gt;NIL, sc-&gt;NIL);
<a name="l03600"></a>03600 s_goto(sc,OP_RDSEXPR);
<a name="l03601"></a>03601 }
<a name="l03602"></a>03602 <span class="keywordflow">case</span> TOK_QUOTE:
<a name="l03603"></a>03603 s_save(sc,OP_RDQUOTE, sc-&gt;NIL, sc-&gt;NIL);
<a name="l03604"></a>03604 sc-&gt;tok = token(sc);
<a name="l03605"></a>03605 s_goto(sc,OP_RDSEXPR);
<a name="l03606"></a>03606 <span class="keywordflow">case</span> TOK_BQUOTE:
<a name="l03607"></a>03607 sc-&gt;tok = token(sc);
<a name="l03608"></a>03608 <span class="keywordflow">if</span>(sc-&gt;tok==TOK_VEC) {
<a name="l03609"></a>03609 s_save(sc,OP_RDQQUOTEVEC, sc-&gt;NIL, sc-&gt;NIL);
<a name="l03610"></a>03610 sc-&gt;tok=TOK_LPAREN;
<a name="l03611"></a>03611 s_goto(sc,OP_RDSEXPR);
<a name="l03612"></a>03612 } <span class="keywordflow">else</span> {
<a name="l03613"></a>03613 s_save(sc,OP_RDQQUOTE, sc-&gt;NIL, sc-&gt;NIL);
<a name="l03614"></a>03614 }
<a name="l03615"></a>03615 s_goto(sc,OP_RDSEXPR);
<a name="l03616"></a>03616 <span class="keywordflow">case</span> TOK_COMMA:
<a name="l03617"></a>03617 s_save(sc,OP_RDUNQUOTE, sc-&gt;NIL, sc-&gt;NIL);
<a name="l03618"></a>03618 sc-&gt;tok = token(sc);
<a name="l03619"></a>03619 s_goto(sc,OP_RDSEXPR);
<a name="l03620"></a>03620 <span class="keywordflow">case</span> TOK_ATMARK:
<a name="l03621"></a>03621 s_save(sc,OP_RDUQTSP, sc-&gt;NIL, sc-&gt;NIL);
<a name="l03622"></a>03622 sc-&gt;tok = token(sc);
<a name="l03623"></a>03623 s_goto(sc,OP_RDSEXPR);
<a name="l03624"></a>03624 <span class="keywordflow">case</span> TOK_ATOM:
<a name="l03625"></a>03625 s_return(sc,mk_atom(sc, readstr_upto(sc, <span class="stringliteral">"();\t\n\r "</span>)));
<a name="l03626"></a>03626 <span class="keywordflow">case</span> TOK_DQUOTE:
<a name="l03627"></a>03627 x=readstrexp(sc);
<a name="l03628"></a>03628 <span class="keywordflow">if</span>(x==sc-&gt;F) {
<a name="l03629"></a>03629 Error_0(sc,<span class="stringliteral">"Error reading string"</span>);
<a name="l03630"></a>03630 }
<a name="l03631"></a>03631 setimmutable(x);
<a name="l03632"></a>03632 s_return(sc,x);
<a name="l03633"></a>03633 <span class="keywordflow">case</span> TOK_SHARP: {
<a name="l03634"></a>03634 pointer f=find_slot_in_env(sc,sc-&gt;envir,sc-&gt;SHARP_HOOK,1);
<a name="l03635"></a>03635 <span class="keywordflow">if</span>(f==sc-&gt;NIL) {
<a name="l03636"></a>03636 Error_0(sc,<span class="stringliteral">"undefined sharp expression"</span>);
<a name="l03637"></a>03637 } <span class="keywordflow">else</span> {
<a name="l03638"></a>03638 sc-&gt;code=cons(sc,slot_value_in_env(f),sc-&gt;NIL);
<a name="l03639"></a>03639 s_goto(sc,OP_EVAL);
<a name="l03640"></a>03640 }
<a name="l03641"></a>03641 }
<a name="l03642"></a>03642 <span class="keywordflow">case</span> TOK_SHARP_CONST:
<a name="l03643"></a>03643 <span class="keywordflow">if</span> ((x = mk_sharp_const(sc, readstr_upto(sc, <span class="stringliteral">"();\t\n\r "</span>))) == sc-&gt;NIL) {
<a name="l03644"></a>03644 Error_0(sc,<span class="stringliteral">"undefined sharp expression"</span>);
<a name="l03645"></a>03645 } <span class="keywordflow">else</span> {
<a name="l03646"></a>03646 s_return(sc,x);
<a name="l03647"></a>03647 }
<a name="l03648"></a>03648 <span class="keywordflow">default</span>:
<a name="l03649"></a>03649 Error_0(sc,<span class="stringliteral">"syntax error: illegal token"</span>);
<a name="l03650"></a>03650 }
<a name="l03651"></a>03651 <span class="keywordflow">break</span>;
<a name="l03652"></a>03652
<a name="l03653"></a>03653 <span class="keywordflow">case</span> OP_RDLIST: {
<a name="l03654"></a>03654 sc-&gt;args = cons(sc, sc-&gt;value, sc-&gt;args);
<a name="l03655"></a>03655 sc-&gt;tok = token(sc);
<a name="l03656"></a>03656 <span class="keywordflow">if</span> (sc-&gt;tok == TOK_COMMENT) {
<a name="l03657"></a>03657 <span class="keywordtype">int</span> c;
<a name="l03658"></a>03658 <span class="keywordflow">while</span> ((c=inchar(sc)) != <span class="charliteral">'\n'</span> &amp;&amp; c!=EOF)
<a name="l03659"></a>03659 ;
<a name="l03660"></a>03660 sc-&gt;tok = token(sc);
<a name="l03661"></a>03661 }
<a name="l03662"></a>03662 <span class="keywordflow">if</span> (sc-&gt;tok == TOK_RPAREN) {
<a name="l03663"></a>03663 <span class="keywordtype">int</span> c = inchar(sc);
<a name="l03664"></a>03664 <span class="keywordflow">if</span> (c != <span class="charliteral">'\n'</span>) backchar(sc,c);
<a name="l03665"></a>03665 sc-&gt;nesting_stack[sc-&gt;file_i]--;
<a name="l03666"></a>03666 s_return(sc,reverse_in_place(sc, sc-&gt;NIL, sc-&gt;args));
<a name="l03667"></a>03667 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (sc-&gt;tok == TOK_DOT) {
<a name="l03668"></a>03668 s_save(sc,OP_RDDOT, sc-&gt;args, sc-&gt;NIL);
<a name="l03669"></a>03669 sc-&gt;tok = token(sc);
<a name="l03670"></a>03670 s_goto(sc,OP_RDSEXPR);
<a name="l03671"></a>03671 } <span class="keywordflow">else</span> {
<a name="l03672"></a>03672 s_save(sc,OP_RDLIST, sc-&gt;args, sc-&gt;NIL);;
<a name="l03673"></a>03673 s_goto(sc,OP_RDSEXPR);
<a name="l03674"></a>03674 }
<a name="l03675"></a>03675 }
<a name="l03676"></a>03676
<a name="l03677"></a>03677 <span class="keywordflow">case</span> OP_RDDOT:
<a name="l03678"></a>03678 <span class="keywordflow">if</span> (token(sc) != TOK_RPAREN) {
<a name="l03679"></a>03679 Error_0(sc,<span class="stringliteral">"syntax error: illegal dot expression"</span>);
<a name="l03680"></a>03680 } <span class="keywordflow">else</span> {
<a name="l03681"></a>03681 sc-&gt;nesting_stack[sc-&gt;file_i]--;
<a name="l03682"></a>03682 s_return(sc,reverse_in_place(sc, sc-&gt;value, sc-&gt;args));
<a name="l03683"></a>03683 }
<a name="l03684"></a>03684
<a name="l03685"></a>03685 <span class="keywordflow">case</span> OP_RDQUOTE:
<a name="l03686"></a>03686 s_return(sc,cons(sc, sc-&gt;QUOTE, cons(sc, sc-&gt;value, sc-&gt;NIL)));
<a name="l03687"></a>03687
<a name="l03688"></a>03688 <span class="keywordflow">case</span> OP_RDQQUOTE:
<a name="l03689"></a>03689 s_return(sc,cons(sc, sc-&gt;QQUOTE, cons(sc, sc-&gt;value, sc-&gt;NIL)));
<a name="l03690"></a>03690
<a name="l03691"></a>03691 <span class="keywordflow">case</span> OP_RDQQUOTEVEC:
<a name="l03692"></a>03692 s_return(sc,cons(sc, mk_symbol(sc,<span class="stringliteral">"apply"</span>),
<a name="l03693"></a>03693 cons(sc, mk_symbol(sc,<span class="stringliteral">"vector"</span>),
<a name="l03694"></a>03694 cons(sc,cons(sc, sc-&gt;QQUOTE,
<a name="l03695"></a>03695 cons(sc,sc-&gt;value,sc-&gt;NIL)),
<a name="l03696"></a>03696 sc-&gt;NIL))));
<a name="l03697"></a>03697
<a name="l03698"></a>03698 <span class="keywordflow">case</span> OP_RDUNQUOTE:
<a name="l03699"></a>03699 s_return(sc,cons(sc, sc-&gt;UNQUOTE, cons(sc, sc-&gt;value, sc-&gt;NIL)));
<a name="l03700"></a>03700
<a name="l03701"></a>03701 <span class="keywordflow">case</span> OP_RDUQTSP:
<a name="l03702"></a>03702 s_return(sc,cons(sc, sc-&gt;UNQUOTESP, cons(sc, sc-&gt;value, sc-&gt;NIL)));
<a name="l03703"></a>03703
<a name="l03704"></a>03704 <span class="keywordflow">case</span> OP_RDVEC:
<a name="l03705"></a>03705 <span class="comment">/*sc-&gt;code=cons(sc,mk_proc(sc,OP_VECTOR),sc-&gt;value);</span>
<a name="l03706"></a>03706 <span class="comment"> s_goto(sc,OP_EVAL); Cannot be quoted*/</span>
<a name="l03707"></a>03707 <span class="comment">/*x=cons(sc,mk_proc(sc,OP_VECTOR),sc-&gt;value);</span>
<a name="l03708"></a>03708 <span class="comment"> s_return(sc,x); Cannot be part of pairs*/</span>
<a name="l03709"></a>03709 <span class="comment">/*sc-&gt;code=mk_proc(sc,OP_VECTOR);</span>
<a name="l03710"></a>03710 <span class="comment"> sc-&gt;args=sc-&gt;value;</span>
<a name="l03711"></a>03711 <span class="comment"> s_goto(sc,OP_APPLY);*/</span>
<a name="l03712"></a>03712 sc-&gt;args=sc-&gt;value;
<a name="l03713"></a>03713 s_goto(sc,OP_VECTOR);
<a name="l03714"></a>03714
<a name="l03715"></a>03715 <span class="comment">/* ========== printing part ========== */</span>
<a name="l03716"></a>03716 <span class="keywordflow">case</span> OP_P0LIST:
<a name="l03717"></a>03717 <span class="keywordflow">if</span>(is_vector(sc-&gt;args)) {
<a name="l03718"></a>03718 putstr(sc,<span class="stringliteral">"#("</span>);
<a name="l03719"></a>03719 sc-&gt;args=cons(sc,sc-&gt;args,mk_integer(sc,0));
<a name="l03720"></a>03720 s_goto(sc,OP_PVECFROM);
<a name="l03721"></a>03721 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(is_environment(sc-&gt;args)) {
<a name="l03722"></a>03722 putstr(sc,<span class="stringliteral">"#&lt;ENVIRONMENT&gt;"</span>);
<a name="l03723"></a>03723 s_return(sc,sc-&gt;T);
<a name="l03724"></a>03724 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (!is_pair(sc-&gt;args)) {
<a name="l03725"></a>03725 printatom(sc, sc-&gt;args, sc-&gt;print_flag);
<a name="l03726"></a>03726 s_return(sc,sc-&gt;T);
<a name="l03727"></a>03727 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (car(sc-&gt;args) == sc-&gt;QUOTE &amp;&amp; ok_abbrev(cdr(sc-&gt;args))) {
<a name="l03728"></a>03728 putstr(sc, <span class="stringliteral">"'"</span>);
<a name="l03729"></a>03729 sc-&gt;args = cadr(sc-&gt;args);
<a name="l03730"></a>03730 s_goto(sc,OP_P0LIST);
<a name="l03731"></a>03731 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (car(sc-&gt;args) == sc-&gt;QQUOTE &amp;&amp; ok_abbrev(cdr(sc-&gt;args))) {
<a name="l03732"></a>03732 putstr(sc, <span class="stringliteral">"`"</span>);
<a name="l03733"></a>03733 sc-&gt;args = cadr(sc-&gt;args);
<a name="l03734"></a>03734 s_goto(sc,OP_P0LIST);
<a name="l03735"></a>03735 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (car(sc-&gt;args) == sc-&gt;UNQUOTE &amp;&amp; ok_abbrev(cdr(sc-&gt;args))) {
<a name="l03736"></a>03736 putstr(sc, <span class="stringliteral">","</span>);
<a name="l03737"></a>03737 sc-&gt;args = cadr(sc-&gt;args);
<a name="l03738"></a>03738 s_goto(sc,OP_P0LIST);
<a name="l03739"></a>03739 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (car(sc-&gt;args) == sc-&gt;UNQUOTESP &amp;&amp; ok_abbrev(cdr(sc-&gt;args))) {
<a name="l03740"></a>03740 putstr(sc, <span class="stringliteral">",@"</span>);
<a name="l03741"></a>03741 sc-&gt;args = cadr(sc-&gt;args);
<a name="l03742"></a>03742 s_goto(sc,OP_P0LIST);
<a name="l03743"></a>03743 } <span class="keywordflow">else</span> {
<a name="l03744"></a>03744 putstr(sc, <span class="stringliteral">"("</span>);
<a name="l03745"></a>03745 s_save(sc,OP_P1LIST, cdr(sc-&gt;args), sc-&gt;NIL);
<a name="l03746"></a>03746 sc-&gt;args = car(sc-&gt;args);
<a name="l03747"></a>03747 s_goto(sc,OP_P0LIST);
<a name="l03748"></a>03748 }
<a name="l03749"></a>03749
<a name="l03750"></a>03750 <span class="keywordflow">case</span> OP_P1LIST:
<a name="l03751"></a>03751 <span class="keywordflow">if</span> (is_pair(sc-&gt;args)) {
<a name="l03752"></a>03752 s_save(sc,OP_P1LIST, cdr(sc-&gt;args), sc-&gt;NIL);
<a name="l03753"></a>03753 putstr(sc, <span class="stringliteral">" "</span>);
<a name="l03754"></a>03754 sc-&gt;args = car(sc-&gt;args);
<a name="l03755"></a>03755 s_goto(sc,OP_P0LIST);
<a name="l03756"></a>03756 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(is_vector(sc-&gt;args)) {
<a name="l03757"></a>03757 s_save(sc,OP_P1LIST,sc-&gt;NIL,sc-&gt;NIL);
<a name="l03758"></a>03758 putstr(sc, <span class="stringliteral">" . "</span>);
<a name="l03759"></a>03759 s_goto(sc,OP_P0LIST);
<a name="l03760"></a>03760 } <span class="keywordflow">else</span> {
<a name="l03761"></a>03761 <span class="keywordflow">if</span> (sc-&gt;args != sc-&gt;NIL) {
<a name="l03762"></a>03762 putstr(sc, <span class="stringliteral">" . "</span>);
<a name="l03763"></a>03763 printatom(sc, sc-&gt;args, sc-&gt;print_flag);
<a name="l03764"></a>03764 }
<a name="l03765"></a>03765 putstr(sc, <span class="stringliteral">")"</span>);
<a name="l03766"></a>03766 s_return(sc,sc-&gt;T);
<a name="l03767"></a>03767 }
<a name="l03768"></a>03768 <span class="keywordflow">case</span> OP_PVECFROM: {
<a name="l03769"></a>03769 <span class="keywordtype">int</span> i=ivalue_unchecked(cdr(sc-&gt;args));
<a name="l03770"></a>03770 pointer vec=car(sc-&gt;args);
<a name="l03771"></a>03771 <span class="keywordtype">int</span> len=ivalue_unchecked(vec);
<a name="l03772"></a>03772 <span class="keywordflow">if</span>(i==len) {
<a name="l03773"></a>03773 putstr(sc,<span class="stringliteral">")"</span>);
<a name="l03774"></a>03774 s_return(sc,sc-&gt;T);
<a name="l03775"></a>03775 } <span class="keywordflow">else</span> {
<a name="l03776"></a>03776 pointer elem=vector_elem(vec,i);
<a name="l03777"></a>03777 ivalue_unchecked(cdr(sc-&gt;args))=i+1;
<a name="l03778"></a>03778 s_save(sc,OP_PVECFROM, sc-&gt;args, sc-&gt;NIL);
<a name="l03779"></a>03779 sc-&gt;args=elem;
<a name="l03780"></a>03780 putstr(sc,<span class="stringliteral">" "</span>);
<a name="l03781"></a>03781 s_goto(sc,OP_P0LIST);
<a name="l03782"></a>03782 }
<a name="l03783"></a>03783 }
<a name="l03784"></a>03784
<a name="l03785"></a>03785 <span class="keywordflow">default</span>:
<a name="l03786"></a>03786 sprintf(sc-&gt;strbuff, <span class="stringliteral">"%d: illegal operator"</span>, sc-&gt;op);
<a name="l03787"></a>03787 Error_0(sc,sc-&gt;strbuff);
<a name="l03788"></a>03788
<a name="l03789"></a>03789 }
<a name="l03790"></a>03790 <span class="keywordflow">return</span> sc-&gt;T;
<a name="l03791"></a>03791 }
<a name="l03792"></a>03792
<a name="l03793"></a>03793 <span class="keyword">static</span> pointer opexe_6(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op) {
<a name="l03794"></a>03794 pointer x, y;
<a name="l03795"></a>03795 <span class="keywordtype">long</span> v;
<a name="l03796"></a>03796
<a name="l03797"></a>03797 <span class="keywordflow">switch</span> (op) {
<a name="l03798"></a>03798 <span class="keywordflow">case</span> OP_LIST_LENGTH: <span class="comment">/* length */</span> <span class="comment">/* a.k */</span>
<a name="l03799"></a>03799 v=list_length(sc,car(sc-&gt;args));
<a name="l03800"></a>03800 <span class="keywordflow">if</span>(v&lt;0) {
<a name="l03801"></a>03801 Error_1(sc,<span class="stringliteral">"length: not a list:"</span>,car(sc-&gt;args));
<a name="l03802"></a>03802 }
<a name="l03803"></a>03803 s_return(sc,mk_integer(sc, v));
<a name="l03804"></a>03804
<a name="l03805"></a>03805 <span class="keywordflow">case</span> OP_ASSQ: <span class="comment">/* assq */</span> <span class="comment">/* a.k */</span>
<a name="l03806"></a>03806 x = car(sc-&gt;args);
<a name="l03807"></a>03807 <span class="keywordflow">for</span> (y = cadr(sc-&gt;args); is_pair(y); y = cdr(y)) {
<a name="l03808"></a>03808 <span class="keywordflow">if</span> (!is_pair(car(y))) {
<a name="l03809"></a>03809 Error_0(sc,<span class="stringliteral">"unable to handle non pair element"</span>);
<a name="l03810"></a>03810 }
<a name="l03811"></a>03811 <span class="keywordflow">if</span> (x == caar(y))
<a name="l03812"></a>03812 <span class="keywordflow">break</span>;
<a name="l03813"></a>03813 }
<a name="l03814"></a>03814 <span class="keywordflow">if</span> (is_pair(y)) {
<a name="l03815"></a>03815 s_return(sc,car(y));
<a name="l03816"></a>03816 } <span class="keywordflow">else</span> {
<a name="l03817"></a>03817 s_return(sc,sc-&gt;F);
<a name="l03818"></a>03818 }
<a name="l03819"></a>03819
<a name="l03820"></a>03820
<a name="l03821"></a>03821 <span class="keywordflow">case</span> OP_GET_CLOSURE: <span class="comment">/* get-closure-code */</span> <span class="comment">/* a.k */</span>
<a name="l03822"></a>03822 sc-&gt;args = car(sc-&gt;args);
<a name="l03823"></a>03823 <span class="keywordflow">if</span> (sc-&gt;args == sc-&gt;NIL) {
<a name="l03824"></a>03824 s_return(sc,sc-&gt;F);
<a name="l03825"></a>03825 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_closure(sc-&gt;args)) {
<a name="l03826"></a>03826 s_return(sc,cons(sc, sc-&gt;LAMBDA, closure_code(sc-&gt;value)));
<a name="l03827"></a>03827 } <span class="keywordflow">else</span> <span class="keywordflow">if</span> (is_macro(sc-&gt;args)) {
<a name="l03828"></a>03828 s_return(sc,cons(sc, sc-&gt;LAMBDA, closure_code(sc-&gt;value)));
<a name="l03829"></a>03829 } <span class="keywordflow">else</span> {
<a name="l03830"></a>03830 s_return(sc,sc-&gt;F);
<a name="l03831"></a>03831 }
<a name="l03832"></a>03832 <span class="keywordflow">case</span> OP_CLOSUREP: <span class="comment">/* closure? */</span>
<a name="l03833"></a>03833 <span class="comment">/*</span>
<a name="l03834"></a>03834 <span class="comment"> * Note, macro object is also a closure.</span>
<a name="l03835"></a>03835 <span class="comment"> * Therefore, (closure? &lt;#MACRO&gt;) ==&gt; #t</span>
<a name="l03836"></a>03836 <span class="comment"> */</span>
<a name="l03837"></a>03837 s_retbool(is_closure(car(sc-&gt;args)));
<a name="l03838"></a>03838 <span class="keywordflow">case</span> OP_MACROP: <span class="comment">/* macro? */</span>
<a name="l03839"></a>03839 s_retbool(is_macro(car(sc-&gt;args)));
<a name="l03840"></a>03840 <span class="keywordflow">default</span>:
<a name="l03841"></a>03841 sprintf(sc-&gt;strbuff, <span class="stringliteral">"%d: illegal operator"</span>, sc-&gt;op);
<a name="l03842"></a>03842 Error_0(sc,sc-&gt;strbuff);
<a name="l03843"></a>03843 }
<a name="l03844"></a>03844 <span class="keywordflow">return</span> sc-&gt;T; <span class="comment">/* NOTREACHED */</span>
<a name="l03845"></a>03845 }
<a name="l03846"></a>03846
<a name="l03847"></a>03847 <span class="keyword">typedef</span> pointer (*dispatch_func)(scheme *, <span class="keyword">enum</span> scheme_opcodes);
<a name="l03848"></a>03848
<a name="l03849"></a>03849 <span class="keyword">typedef</span> int (*test_predicate)(pointer);
<a name="l03850"></a>03850 <span class="keyword">static</span> <span class="keywordtype">int</span> is_any(pointer p) { <span class="keywordflow">return</span> 1;}
<a name="l03851"></a>03851 <span class="keyword">static</span> <span class="keywordtype">int</span> is_num_integer(pointer p) {
<a name="l03852"></a>03852 <span class="keywordflow">return</span> is_number(p) &amp;&amp; ((p)-&gt;_object._number.is_fixnum);
<a name="l03853"></a>03853 }
<a name="l03854"></a>03854 <span class="keyword">static</span> <span class="keywordtype">int</span> is_nonneg(pointer p) {
<a name="l03855"></a>03855 <span class="keywordflow">return</span> is_num_integer(p) &amp;&amp; ivalue(p)&gt;=0;
<a name="l03856"></a>03856 }
<a name="l03857"></a>03857
<a name="l03858"></a>03858 <span class="comment">/* Correspond carefully with following defines! */</span>
<a name="l03859"></a>03859 <span class="keyword">static</span> <span class="keyword">struct </span>{
<a name="l03860"></a>03860 test_predicate fct;
<a name="l03861"></a>03861 <span class="keyword">const</span> <span class="keywordtype">char</span> *kind;
<a name="l03862"></a>03862 } tests[]={
<a name="l03863"></a>03863 {0,0}, <span class="comment">/* unused */</span>
<a name="l03864"></a>03864 {is_any, 0},
<a name="l03865"></a>03865 {is_string, <span class="stringliteral">"string"</span>},
<a name="l03866"></a>03866 {is_symbol, <span class="stringliteral">"symbol"</span>},
<a name="l03867"></a>03867 {is_port, <span class="stringliteral">"port"</span>},
<a name="l03868"></a>03868 {0,<span class="stringliteral">"input port"</span>},
<a name="l03869"></a>03869 {0,<span class="stringliteral">"output_port"</span>},
<a name="l03870"></a>03870 {is_environment, <span class="stringliteral">"environment"</span>},
<a name="l03871"></a>03871 {is_pair, <span class="stringliteral">"pair"</span>},
<a name="l03872"></a>03872 {0, <span class="stringliteral">"pair or '()"</span>},
<a name="l03873"></a>03873 {is_character, <span class="stringliteral">"character"</span>},
<a name="l03874"></a>03874 {is_vector, <span class="stringliteral">"vector"</span>},
<a name="l03875"></a>03875 {is_number, <span class="stringliteral">"number"</span>},
<a name="l03876"></a>03876 {is_num_integer, <span class="stringliteral">"integer"</span>},
<a name="l03877"></a>03877 {is_nonneg, <span class="stringliteral">"non-negative integer"</span>}
<a name="l03878"></a>03878 };
<a name="l03879"></a>03879
<a name="l03880"></a>03880 <span class="preprocessor">#define TST_NONE 0</span>
<a name="l03881"></a>03881 <span class="preprocessor"></span><span class="preprocessor">#define TST_ANY "\001"</span>
<a name="l03882"></a>03882 <span class="preprocessor"></span><span class="preprocessor">#define TST_STRING "\002"</span>
<a name="l03883"></a>03883 <span class="preprocessor"></span><span class="preprocessor">#define TST_SYMBOL "\003"</span>
<a name="l03884"></a>03884 <span class="preprocessor"></span><span class="preprocessor">#define TST_PORT "\004"</span>
<a name="l03885"></a>03885 <span class="preprocessor"></span><span class="preprocessor">#define TST_INPORT "\005"</span>
<a name="l03886"></a>03886 <span class="preprocessor"></span><span class="preprocessor">#define TST_OUTPORT "\006"</span>
<a name="l03887"></a>03887 <span class="preprocessor"></span><span class="preprocessor">#define TST_ENVIRONMENT "\007"</span>
<a name="l03888"></a>03888 <span class="preprocessor"></span><span class="preprocessor">#define TST_PAIR "\010"</span>
<a name="l03889"></a>03889 <span class="preprocessor"></span><span class="preprocessor">#define TST_LIST "\011"</span>
<a name="l03890"></a>03890 <span class="preprocessor"></span><span class="preprocessor">#define TST_CHAR "\012"</span>
<a name="l03891"></a>03891 <span class="preprocessor"></span><span class="preprocessor">#define TST_VECTOR "\013"</span>
<a name="l03892"></a>03892 <span class="preprocessor"></span><span class="preprocessor">#define TST_NUMBER "\014"</span>
<a name="l03893"></a>03893 <span class="preprocessor"></span><span class="preprocessor">#define TST_INTEGER "\015"</span>
<a name="l03894"></a>03894 <span class="preprocessor"></span><span class="preprocessor">#define TST_NATURAL "\016"</span>
<a name="l03895"></a>03895 <span class="preprocessor"></span>
<a name="l03896"></a>03896 <span class="keyword">typedef</span> <span class="keyword">struct </span>{
<a name="l03897"></a>03897 dispatch_func func;
<a name="l03898"></a>03898 <span class="keywordtype">char</span> *name;
<a name="l03899"></a>03899 <span class="keywordtype">int</span> min_arity;
<a name="l03900"></a>03900 <span class="keywordtype">int</span> max_arity;
<a name="l03901"></a>03901 <span class="keywordtype">char</span> *arg_tests_encoding;
<a name="l03902"></a>03902 } op_code_info;
<a name="l03903"></a>03903
<a name="l03904"></a>03904 <span class="preprocessor">#define INF_ARG 0xffff</span>
<a name="l03905"></a>03905 <span class="preprocessor"></span>
<a name="l03906"></a>03906 <span class="keyword">static</span> op_code_info dispatch_table[]= {
<a name="l03907"></a>03907 <span class="preprocessor">#define _OP_DEF(A,B,C,D,E,OP) {A,B,C,D,E}, </span>
<a name="l03908"></a>03908 <span class="preprocessor"></span><span class="preprocessor">#include "<a class="code" href="opdefines_8h.html" title="More support data for the TinyScheme parser.">opdefines.h</a>"</span>
<a name="l03909"></a>03909 { 0 }
<a name="l03910"></a>03910 };
<a name="l03911"></a>03911
<a name="l03912"></a>03912 <span class="keyword">static</span> <span class="keyword">const</span> <span class="keywordtype">char</span> *procname(pointer x) {
<a name="l03913"></a>03913 <span class="keywordtype">int</span> n=procnum(x);
<a name="l03914"></a>03914 <span class="keyword">const</span> <span class="keywordtype">char</span> *name=dispatch_table[n].name;
<a name="l03915"></a>03915 <span class="keywordflow">if</span>(name==0) {
<a name="l03916"></a>03916 name=<span class="stringliteral">"ILLEGAL!"</span>;
<a name="l03917"></a>03917 }
<a name="l03918"></a>03918 <span class="keywordflow">return</span> name;
<a name="l03919"></a>03919 }
<a name="l03920"></a>03920
<a name="l03921"></a>03921 <span class="comment">/* kernel of this interpreter */</span>
<a name="l03922"></a>03922 <span class="keyword">static</span> <span class="keywordtype">void</span> Eval_Cycle(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op) {
<a name="l03923"></a>03923 <span class="keywordtype">int</span> count=0;
<a name="l03924"></a>03924 <span class="keywordtype">int</span> old_op;
<a name="l03925"></a>03925
<a name="l03926"></a>03926 sc-&gt;op = op;
<a name="l03927"></a>03927 <span class="keywordflow">for</span> (;;) {
<a name="l03928"></a>03928 op_code_info *pcd=dispatch_table+sc-&gt;op;
<a name="l03929"></a>03929 <span class="keywordflow">if</span> (pcd-&gt;name!=0) { <span class="comment">/* if built-in function, check arguments */</span>
<a name="l03930"></a>03930 <span class="keywordtype">char</span> msg[512];
<a name="l03931"></a>03931 <span class="keywordtype">int</span> ok=1;
<a name="l03932"></a>03932 <span class="keywordtype">int</span> n=list_length(sc,sc-&gt;args);
<a name="l03933"></a>03933
<a name="l03934"></a>03934 <span class="comment">/* Check number of arguments */</span>
<a name="l03935"></a>03935 <span class="keywordflow">if</span>(n&lt;pcd-&gt;min_arity) {
<a name="l03936"></a>03936 ok=0;
<a name="l03937"></a>03937 sprintf(msg,<span class="stringliteral">"%s: needs%s %d argument(s)"</span>,
<a name="l03938"></a>03938 pcd-&gt;name,
<a name="l03939"></a>03939 pcd-&gt;min_arity==pcd-&gt;max_arity?<span class="stringliteral">""</span>:<span class="stringliteral">" at least"</span>,
<a name="l03940"></a>03940 pcd-&gt;min_arity);
<a name="l03941"></a>03941 }
<a name="l03942"></a>03942 <span class="keywordflow">if</span>(ok &amp;&amp; n&gt;pcd-&gt;max_arity) {
<a name="l03943"></a>03943 ok=0;
<a name="l03944"></a>03944 sprintf(msg,<span class="stringliteral">"%s: needs%s %d argument(s)"</span>,
<a name="l03945"></a>03945 pcd-&gt;name,
<a name="l03946"></a>03946 pcd-&gt;min_arity==pcd-&gt;max_arity?<span class="stringliteral">""</span>:<span class="stringliteral">" at most"</span>,
<a name="l03947"></a>03947 pcd-&gt;max_arity);
<a name="l03948"></a>03948 }
<a name="l03949"></a>03949 <span class="keywordflow">if</span>(ok) {
<a name="l03950"></a>03950 <span class="keywordflow">if</span>(pcd-&gt;arg_tests_encoding!=0) {
<a name="l03951"></a>03951 <span class="keywordtype">int</span> i=0;
<a name="l03952"></a>03952 <span class="keywordtype">int</span> j;
<a name="l03953"></a>03953 <span class="keyword">const</span> <span class="keywordtype">char</span> *t=pcd-&gt;arg_tests_encoding;
<a name="l03954"></a>03954 pointer arglist=sc-&gt;args;
<a name="l03955"></a>03955 <span class="keywordflow">do</span> {
<a name="l03956"></a>03956 pointer arg=car(arglist);
<a name="l03957"></a>03957 j=(int)t[0];
<a name="l03958"></a>03958 <span class="keywordflow">if</span>(j==TST_INPORT[0]) {
<a name="l03959"></a>03959 <span class="keywordflow">if</span>(!is_inport(arg)) <span class="keywordflow">break</span>;
<a name="l03960"></a>03960 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(j==TST_OUTPORT[0]) {
<a name="l03961"></a>03961 <span class="keywordflow">if</span>(!is_outport(arg)) <span class="keywordflow">break</span>;
<a name="l03962"></a>03962 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(j==TST_LIST[0]) {
<a name="l03963"></a>03963 <span class="keywordflow">if</span>(arg!=sc-&gt;NIL &amp;&amp; !is_pair(arg)) <span class="keywordflow">break</span>;
<a name="l03964"></a>03964 } <span class="keywordflow">else</span> {
<a name="l03965"></a>03965 <span class="keywordflow">if</span>(!tests[j].fct(arg)) <span class="keywordflow">break</span>;
<a name="l03966"></a>03966 }
<a name="l03967"></a>03967
<a name="l03968"></a>03968 <span class="keywordflow">if</span>(t[1]!=0) {<span class="comment">/* last test is replicated as necessary */</span>
<a name="l03969"></a>03969 t++;
<a name="l03970"></a>03970 }
<a name="l03971"></a>03971 arglist=cdr(arglist);
<a name="l03972"></a>03972 i++;
<a name="l03973"></a>03973 } <span class="keywordflow">while</span>(i&lt;n);
<a name="l03974"></a>03974 <span class="keywordflow">if</span>(i&lt;n) {
<a name="l03975"></a>03975 ok=0;
<a name="l03976"></a>03976 sprintf(msg,<span class="stringliteral">"%s: argument %d must be: %s"</span>,
<a name="l03977"></a>03977 pcd-&gt;name,
<a name="l03978"></a>03978 i+1,
<a name="l03979"></a>03979 tests[j].kind);
<a name="l03980"></a>03980 }
<a name="l03981"></a>03981 }
<a name="l03982"></a>03982 }
<a name="l03983"></a>03983 <span class="keywordflow">if</span>(!ok) {
<a name="l03984"></a>03984 <span class="keywordflow">if</span>(_Error_1(sc,msg,0)==sc-&gt;NIL) {
<a name="l03985"></a>03985 <span class="keywordflow">return</span>;
<a name="l03986"></a>03986 }
<a name="l03987"></a>03987 pcd=dispatch_table+sc-&gt;op;
<a name="l03988"></a>03988 }
<a name="l03989"></a>03989 }
<a name="l03990"></a>03990 old_op=sc-&gt;op;
<a name="l03991"></a>03991 <span class="keywordflow">if</span> (pcd-&gt;func(sc, (<span class="keyword">enum</span> scheme_opcodes)sc-&gt;op) == sc-&gt;NIL) {
<a name="l03992"></a>03992 <span class="keywordflow">return</span>;
<a name="l03993"></a>03993 }
<a name="l03994"></a>03994 <span class="keywordflow">if</span>(sc-&gt;no_memory) {
<a name="l03995"></a>03995 fprintf(stderr,<span class="stringliteral">"No memory!\n"</span>);
<a name="l03996"></a>03996 <span class="keywordflow">return</span>;
<a name="l03997"></a>03997 }
<a name="l03998"></a>03998 count++;
<a name="l03999"></a>03999 }
<a name="l04000"></a>04000 }
<a name="l04001"></a>04001
<a name="l04002"></a>04002 <span class="comment">/* ========== Initialization of internal keywords ========== */</span>
<a name="l04003"></a>04003
<a name="l04004"></a>04004 <span class="keyword">static</span> <span class="keywordtype">void</span> assign_syntax(scheme *sc, <span class="keywordtype">char</span> *name) {
<a name="l04005"></a>04005 pointer x;
<a name="l04006"></a>04006
<a name="l04007"></a>04007 x = oblist_add_by_name(sc, name);
<a name="l04008"></a>04008 typeflag(x) |= T_SYNTAX;
<a name="l04009"></a>04009 }
<a name="l04010"></a>04010
<a name="l04011"></a>04011 <span class="keyword">static</span> <span class="keywordtype">void</span> assign_proc(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op, <span class="keywordtype">char</span> *name) {
<a name="l04012"></a>04012 pointer x, y;
<a name="l04013"></a>04013
<a name="l04014"></a>04014 x = mk_symbol(sc, name);
<a name="l04015"></a>04015 y = mk_proc(sc,op);
<a name="l04016"></a>04016 new_slot_in_env(sc, x, y);
<a name="l04017"></a>04017 }
<a name="l04018"></a>04018
<a name="l04019"></a>04019 <span class="keyword">static</span> pointer mk_proc(scheme *sc, <span class="keyword">enum</span> scheme_opcodes op) {
<a name="l04020"></a>04020 pointer y;
<a name="l04021"></a>04021
<a name="l04022"></a>04022 y = get_cell(sc, sc-&gt;NIL, sc-&gt;NIL);
<a name="l04023"></a>04023 typeflag(y) = (T_PROC | T_ATOM);
<a name="l04024"></a>04024 ivalue_unchecked(y) = (long) op;
<a name="l04025"></a>04025 set_integer(y);
<a name="l04026"></a>04026 <span class="keywordflow">return</span> y;
<a name="l04027"></a>04027 }
<a name="l04028"></a>04028
<a name="l04029"></a>04029 <span class="comment">/* Hard-coded for the given keywords. Remember to rewrite if more are added! */</span>
<a name="l04030"></a>04030 <span class="keyword">static</span> <span class="keywordtype">int</span> syntaxnum(pointer p) {
<a name="l04031"></a>04031 <span class="keyword">const</span> <span class="keywordtype">char</span> *s=strvalue(car(p));
<a name="l04032"></a>04032 <span class="keywordflow">switch</span>(strlength(car(p))) {
<a name="l04033"></a>04033 <span class="keywordflow">case</span> 2:
<a name="l04034"></a>04034 <span class="keywordflow">if</span>(s[0]==<span class="charliteral">'i'</span>) <span class="keywordflow">return</span> OP_IF0; <span class="comment">/* if */</span>
<a name="l04035"></a>04035 <span class="keywordflow">else</span> <span class="keywordflow">return</span> OP_OR0; <span class="comment">/* or */</span>
<a name="l04036"></a>04036 <span class="keywordflow">case</span> 3:
<a name="l04037"></a>04037 <span class="keywordflow">if</span>(s[0]==<span class="charliteral">'a'</span>) <span class="keywordflow">return</span> OP_AND0; <span class="comment">/* and */</span>
<a name="l04038"></a>04038 <span class="keywordflow">else</span> <span class="keywordflow">return</span> OP_LET0; <span class="comment">/* let */</span>
<a name="l04039"></a>04039 <span class="keywordflow">case</span> 4:
<a name="l04040"></a>04040 <span class="keywordflow">switch</span>(s[3]) {
<a name="l04041"></a>04041 <span class="keywordflow">case</span> <span class="charliteral">'e'</span>: <span class="keywordflow">return</span> OP_CASE0; <span class="comment">/* case */</span>
<a name="l04042"></a>04042 <span class="keywordflow">case</span> <span class="charliteral">'d'</span>: <span class="keywordflow">return</span> OP_COND0; <span class="comment">/* cond */</span>
<a name="l04043"></a>04043 <span class="keywordflow">case</span> <span class="charliteral">'*'</span>: <span class="keywordflow">return</span> OP_LET0AST; <span class="comment">/* let* */</span>
<a name="l04044"></a>04044 <span class="keywordflow">default</span>: <span class="keywordflow">return</span> OP_SET0; <span class="comment">/* set! */</span>
<a name="l04045"></a>04045 }
<a name="l04046"></a>04046 <span class="keywordflow">case</span> 5:
<a name="l04047"></a>04047 <span class="keywordflow">switch</span>(s[2]) {
<a name="l04048"></a>04048 <span class="keywordflow">case</span> <span class="charliteral">'g'</span>: <span class="keywordflow">return</span> OP_BEGIN; <span class="comment">/* begin */</span>
<a name="l04049"></a>04049 <span class="keywordflow">case</span> <span class="charliteral">'l'</span>: <span class="keywordflow">return</span> OP_DELAY; <span class="comment">/* delay */</span>
<a name="l04050"></a>04050 <span class="keywordflow">case</span> <span class="charliteral">'c'</span>: <span class="keywordflow">return</span> OP_MACRO0; <span class="comment">/* macro */</span>
<a name="l04051"></a>04051 <span class="keywordflow">default</span>: <span class="keywordflow">return</span> OP_QUOTE; <span class="comment">/* quote */</span>
<a name="l04052"></a>04052 }
<a name="l04053"></a>04053 <span class="keywordflow">case</span> 6:
<a name="l04054"></a>04054 <span class="keywordflow">switch</span>(s[2]) {
<a name="l04055"></a>04055 <span class="keywordflow">case</span> <span class="charliteral">'m'</span>: <span class="keywordflow">return</span> OP_LAMBDA; <span class="comment">/* lambda */</span>
<a name="l04056"></a>04056 <span class="keywordflow">case</span> <span class="charliteral">'f'</span>: <span class="keywordflow">return</span> OP_DEF0; <span class="comment">/* define */</span>
<a name="l04057"></a>04057 <span class="keywordflow">default</span>: <span class="keywordflow">return</span> OP_LET0REC; <span class="comment">/* letrec */</span>
<a name="l04058"></a>04058 }
<a name="l04059"></a>04059 <span class="keywordflow">default</span>:
<a name="l04060"></a>04060 <span class="keywordflow">return</span> OP_C0STREAM; <span class="comment">/* cons-stream */</span>
<a name="l04061"></a>04061 }
<a name="l04062"></a>04062 }
<a name="l04063"></a>04063
<a name="l04064"></a>04064 <span class="comment">/* initialization of TinyScheme */</span>
<a name="l04065"></a>04065 <span class="preprocessor">#if USE_INTERFACE</span>
<a name="l04066"></a>04066 <span class="preprocessor"></span>INTERFACE <span class="keyword">static</span> pointer s_cons(scheme *sc, pointer a, pointer b) {
<a name="l04067"></a>04067 <span class="keywordflow">return</span> cons(sc,a,b);
<a name="l04068"></a>04068 }
<a name="l04069"></a>04069 INTERFACE <span class="keyword">static</span> pointer s_immutable_cons(scheme *sc, pointer a, pointer b) {
<a name="l04070"></a>04070 <span class="keywordflow">return</span> immutable_cons(sc,a,b);
<a name="l04071"></a>04071 }
<a name="l04072"></a>04072
<a name="l04073"></a>04073 <span class="keyword">static</span> <span class="keyword">struct </span>scheme_interface vtbl ={
<a name="l04074"></a>04074 scheme_define,
<a name="l04075"></a>04075 s_cons,
<a name="l04076"></a>04076 s_immutable_cons,
<a name="l04077"></a>04077 mk_integer,
<a name="l04078"></a>04078 mk_real,
<a name="l04079"></a>04079 mk_symbol,
<a name="l04080"></a>04080 gensym,
<a name="l04081"></a>04081 mk_string,
<a name="l04082"></a>04082 mk_counted_string,
<a name="l04083"></a>04083 mk_character,
<a name="l04084"></a>04084 mk_vector,
<a name="l04085"></a>04085 mk_foreign_func,
<a name="l04086"></a>04086 putstr,
<a name="l04087"></a>04087 putcharacter,
<a name="l04088"></a>04088
<a name="l04089"></a>04089 is_string,
<a name="l04090"></a>04090 string_value,
<a name="l04091"></a>04091 is_number,
<a name="l04092"></a>04092 nvalue,
<a name="l04093"></a>04093 ivalue,
<a name="l04094"></a>04094 rvalue,
<a name="l04095"></a>04095 is_integer,
<a name="l04096"></a>04096 is_real,
<a name="l04097"></a>04097 is_character,
<a name="l04098"></a>04098 charvalue,
<a name="l04099"></a>04099 is_vector,
<a name="l04100"></a>04100 ivalue,
<a name="l04101"></a>04101 fill_vector,
<a name="l04102"></a>04102 vector_elem,
<a name="l04103"></a>04103 set_vector_elem,
<a name="l04104"></a>04104 is_port,
<a name="l04105"></a>04105 is_pair,
<a name="l04106"></a>04106 pair_car,
<a name="l04107"></a>04107 pair_cdr,
<a name="l04108"></a>04108 set_car,
<a name="l04109"></a>04109 set_cdr,
<a name="l04110"></a>04110
<a name="l04111"></a>04111 is_symbol,
<a name="l04112"></a>04112 symname,
<a name="l04113"></a>04113
<a name="l04114"></a>04114 is_syntax,
<a name="l04115"></a>04115 is_proc,
<a name="l04116"></a>04116 is_foreign,
<a name="l04117"></a>04117 syntaxname,
<a name="l04118"></a>04118 is_closure,
<a name="l04119"></a>04119 is_macro,
<a name="l04120"></a>04120 closure_code,
<a name="l04121"></a>04121 closure_env,
<a name="l04122"></a>04122
<a name="l04123"></a>04123 is_continuation,
<a name="l04124"></a>04124 is_promise,
<a name="l04125"></a>04125 is_environment,
<a name="l04126"></a>04126 is_immutable,
<a name="l04127"></a>04127 setimmutable,
<a name="l04128"></a>04128
<a name="l04129"></a>04129 scheme_load_file,
<a name="l04130"></a>04130 scheme_load_string
<a name="l04131"></a>04131 };
<a name="l04132"></a>04132 <span class="preprocessor">#endif</span>
<a name="l04133"></a>04133 <span class="preprocessor"></span>
<a name="l04134"></a>04134 scheme *scheme_init_new() {
<a name="l04135"></a>04135 scheme *sc=(scheme*)malloc(<span class="keyword">sizeof</span>(scheme));
<a name="l04136"></a>04136 <span class="keywordflow">if</span>(!scheme_init(sc)) {
<a name="l04137"></a>04137 free(sc);
<a name="l04138"></a>04138 <span class="keywordflow">return</span> 0;
<a name="l04139"></a>04139 } <span class="keywordflow">else</span> {
<a name="l04140"></a>04140 <span class="keywordflow">return</span> sc;
<a name="l04141"></a>04141 }
<a name="l04142"></a>04142 }
<a name="l04143"></a>04143
<a name="l04144"></a>04144 scheme *scheme_init_new_custom_alloc(func_alloc malloc, func_dealloc free) {
<a name="l04145"></a>04145 scheme *sc=(scheme*)malloc(<span class="keyword">sizeof</span>(scheme));
<a name="l04146"></a>04146 <span class="keywordflow">if</span>(!scheme_init_custom_alloc(sc,malloc,free)) {
<a name="l04147"></a>04147 free(sc);
<a name="l04148"></a>04148 <span class="keywordflow">return</span> 0;
<a name="l04149"></a>04149 } <span class="keywordflow">else</span> {
<a name="l04150"></a>04150 <span class="keywordflow">return</span> sc;
<a name="l04151"></a>04151 }
<a name="l04152"></a>04152 }
<a name="l04153"></a>04153
<a name="l04154"></a>04154
<a name="l04155"></a>04155 <span class="keywordtype">int</span> scheme_init(scheme *sc) {
<a name="l04156"></a>04156 <span class="keywordflow">return</span> scheme_init_custom_alloc(sc,malloc,free);
<a name="l04157"></a>04157 }
<a name="l04158"></a>04158
<a name="l04159"></a>04159 <span class="keywordtype">int</span> scheme_init_custom_alloc(scheme *sc, func_alloc malloc, func_dealloc free) {
<a name="l04160"></a>04160 <span class="keywordtype">int</span> i, n=<span class="keyword">sizeof</span>(dispatch_table)/<span class="keyword">sizeof</span>(dispatch_table[0]);
<a name="l04161"></a>04161 pointer x;
<a name="l04162"></a>04162
<a name="l04163"></a>04163 num_zero.is_fixnum=1;
<a name="l04164"></a>04164 num_zero.value.ivalue=0;
<a name="l04165"></a>04165 num_one.is_fixnum=1;
<a name="l04166"></a>04166 num_one.value.ivalue=1;
<a name="l04167"></a>04167
<a name="l04168"></a>04168 <span class="preprocessor">#if USE_INTERFACE</span>
<a name="l04169"></a>04169 <span class="preprocessor"></span> sc-&gt;vptr=&amp;vtbl;
<a name="l04170"></a>04170 <span class="preprocessor">#endif</span>
<a name="l04171"></a>04171 <span class="preprocessor"></span> sc-&gt;gensym_cnt=0;
<a name="l04172"></a>04172 sc-&gt;malloc=malloc;
<a name="l04173"></a>04173 sc-&gt;free=free;
<a name="l04174"></a>04174 sc-&gt;last_cell_seg = -1;
<a name="l04175"></a>04175 sc-&gt;sink = &amp;sc-&gt;_sink;
<a name="l04176"></a>04176 sc-&gt;NIL = &amp;sc-&gt;_NIL;
<a name="l04177"></a>04177 sc-&gt;T = &amp;sc-&gt;_HASHT;
<a name="l04178"></a>04178 sc-&gt;F = &amp;sc-&gt;_HASHF;
<a name="l04179"></a>04179 sc-&gt;EOF_OBJ=&amp;sc-&gt;_EOF_OBJ;
<a name="l04180"></a>04180 sc-&gt;free_cell = &amp;sc-&gt;_NIL;
<a name="l04181"></a>04181 sc-&gt;fcells = 0;
<a name="l04182"></a>04182 sc-&gt;no_memory=0;
<a name="l04183"></a>04183 sc-&gt;inport=sc-&gt;NIL;
<a name="l04184"></a>04184 sc-&gt;outport=sc-&gt;NIL;
<a name="l04185"></a>04185 sc-&gt;save_inport=sc-&gt;NIL;
<a name="l04186"></a>04186 sc-&gt;loadport=sc-&gt;NIL;
<a name="l04187"></a>04187 sc-&gt;nesting=0;
<a name="l04188"></a>04188 sc-&gt;interactive_repl=0;
<a name="l04189"></a>04189
<a name="l04190"></a>04190 <span class="keywordflow">if</span> (alloc_cellseg(sc,FIRST_CELLSEGS) != FIRST_CELLSEGS) {
<a name="l04191"></a>04191 sc-&gt;no_memory=1;
<a name="l04192"></a>04192 <span class="keywordflow">return</span> 0;
<a name="l04193"></a>04193 }
<a name="l04194"></a>04194 sc-&gt;gc_verbose = 0;
<a name="l04195"></a>04195 dump_stack_initialize(sc);
<a name="l04196"></a>04196 sc-&gt;code = sc-&gt;NIL;
<a name="l04197"></a>04197 sc-&gt;tracing=0;
<a name="l04198"></a>04198
<a name="l04199"></a>04199 <span class="comment">/* init sc-&gt;NIL */</span>
<a name="l04200"></a>04200 typeflag(sc-&gt;NIL) = (T_ATOM | MARK);
<a name="l04201"></a>04201 car(sc-&gt;NIL) = cdr(sc-&gt;NIL) = sc-&gt;NIL;
<a name="l04202"></a>04202 <span class="comment">/* init T */</span>
<a name="l04203"></a>04203 typeflag(sc-&gt;T) = (T_ATOM | MARK);
<a name="l04204"></a>04204 car(sc-&gt;T) = cdr(sc-&gt;T) = sc-&gt;T;
<a name="l04205"></a>04205 <span class="comment">/* init F */</span>
<a name="l04206"></a>04206 typeflag(sc-&gt;F) = (T_ATOM | MARK);
<a name="l04207"></a>04207 car(sc-&gt;F) = cdr(sc-&gt;F) = sc-&gt;F;
<a name="l04208"></a>04208 sc-&gt;oblist = oblist_initial_value(sc);
<a name="l04209"></a>04209 <span class="comment">/* init global_env */</span>
<a name="l04210"></a>04210 new_frame_in_env(sc, sc-&gt;NIL);
<a name="l04211"></a>04211 sc-&gt;global_env = sc-&gt;envir;
<a name="l04212"></a>04212 <span class="comment">/* init else */</span>
<a name="l04213"></a>04213 x = mk_symbol(sc,<span class="stringliteral">"else"</span>);
<a name="l04214"></a>04214 new_slot_in_env(sc, x, sc-&gt;T);
<a name="l04215"></a>04215
<a name="l04216"></a>04216 assign_syntax(sc, <span class="stringliteral">"lambda"</span>);
<a name="l04217"></a>04217 assign_syntax(sc, <span class="stringliteral">"quote"</span>);
<a name="l04218"></a>04218 assign_syntax(sc, <span class="stringliteral">"define"</span>);
<a name="l04219"></a>04219 assign_syntax(sc, <span class="stringliteral">"if"</span>);
<a name="l04220"></a>04220 assign_syntax(sc, <span class="stringliteral">"begin"</span>);
<a name="l04221"></a>04221 assign_syntax(sc, <span class="stringliteral">"set!"</span>);
<a name="l04222"></a>04222 assign_syntax(sc, <span class="stringliteral">"let"</span>);
<a name="l04223"></a>04223 assign_syntax(sc, <span class="stringliteral">"let*"</span>);
<a name="l04224"></a>04224 assign_syntax(sc, <span class="stringliteral">"letrec"</span>);
<a name="l04225"></a>04225 assign_syntax(sc, <span class="stringliteral">"cond"</span>);
<a name="l04226"></a>04226 assign_syntax(sc, <span class="stringliteral">"delay"</span>);
<a name="l04227"></a>04227 assign_syntax(sc, <span class="stringliteral">"and"</span>);
<a name="l04228"></a>04228 assign_syntax(sc, <span class="stringliteral">"or"</span>);
<a name="l04229"></a>04229 assign_syntax(sc, <span class="stringliteral">"cons-stream"</span>);
<a name="l04230"></a>04230 assign_syntax(sc, <span class="stringliteral">"macro"</span>);
<a name="l04231"></a>04231 assign_syntax(sc, <span class="stringliteral">"case"</span>);
<a name="l04232"></a>04232
<a name="l04233"></a>04233 <span class="keywordflow">for</span>(i=0; i&lt;n; i++) {
<a name="l04234"></a>04234 <span class="keywordflow">if</span>(dispatch_table[i].name!=0) {
<a name="l04235"></a>04235 assign_proc(sc, (<span class="keyword">enum</span> scheme_opcodes)i, dispatch_table[i].name);
<a name="l04236"></a>04236 }
<a name="l04237"></a>04237 }
<a name="l04238"></a>04238
<a name="l04239"></a>04239 <span class="comment">/* initialization of global pointers to special symbols */</span>
<a name="l04240"></a>04240 sc-&gt;LAMBDA = mk_symbol(sc, <span class="stringliteral">"lambda"</span>);
<a name="l04241"></a>04241 sc-&gt;QUOTE = mk_symbol(sc, <span class="stringliteral">"quote"</span>);
<a name="l04242"></a>04242 sc-&gt;QQUOTE = mk_symbol(sc, <span class="stringliteral">"quasiquote"</span>);
<a name="l04243"></a>04243 sc-&gt;UNQUOTE = mk_symbol(sc, <span class="stringliteral">"unquote"</span>);
<a name="l04244"></a>04244 sc-&gt;UNQUOTESP = mk_symbol(sc, <span class="stringliteral">"unquote-splicing"</span>);
<a name="l04245"></a>04245 sc-&gt;FEED_TO = mk_symbol(sc, <span class="stringliteral">"=&gt;"</span>);
<a name="l04246"></a>04246 sc-&gt;COLON_HOOK = mk_symbol(sc,<span class="stringliteral">"*colon-hook*"</span>);
<a name="l04247"></a>04247 sc-&gt;ERROR_HOOK = mk_symbol(sc, <span class="stringliteral">"*error-hook*"</span>);
<a name="l04248"></a>04248 sc-&gt;SHARP_HOOK = mk_symbol(sc, <span class="stringliteral">"*sharp-hook*"</span>);
<a name="l04249"></a>04249
<a name="l04250"></a>04250 <span class="keywordflow">return</span> !sc-&gt;no_memory;
<a name="l04251"></a>04251 }
<a name="l04252"></a>04252
<a name="l04253"></a>04253 <span class="keywordtype">void</span> scheme_set_input_port_file(scheme *sc, FILE *fin) {
<a name="l04254"></a>04254 sc-&gt;inport=port_from_file(sc,fin,port_input);
<a name="l04255"></a>04255 }
<a name="l04256"></a>04256
<a name="l04257"></a>04257 <span class="keywordtype">void</span> scheme_set_input_port_string(scheme *sc, <span class="keywordtype">char</span> *start, <span class="keywordtype">char</span> *past_the_end) {
<a name="l04258"></a>04258 sc-&gt;inport=port_from_string(sc,start,past_the_end,port_input);
<a name="l04259"></a>04259 }
<a name="l04260"></a>04260
<a name="l04261"></a>04261 <span class="keywordtype">void</span> scheme_set_output_port_file(scheme *sc, FILE *fout) {
<a name="l04262"></a>04262 sc-&gt;outport=port_from_file(sc,fout,port_output);
<a name="l04263"></a>04263 }
<a name="l04264"></a>04264
<a name="l04265"></a>04265 <span class="keywordtype">void</span> scheme_set_output_port_string(scheme *sc, <span class="keywordtype">char</span> *start, <span class="keywordtype">char</span> *past_the_end) {
<a name="l04266"></a>04266 sc-&gt;outport=port_from_string(sc,start,past_the_end,port_output);
<a name="l04267"></a>04267 }
<a name="l04268"></a>04268
<a name="l04269"></a>04269 <span class="keywordtype">void</span> scheme_set_external_data(scheme *sc, <span class="keywordtype">void</span> *p) {
<a name="l04270"></a>04270 sc-&gt;ext_data=p;
<a name="l04271"></a>04271 }
<a name="l04272"></a>04272
<a name="l04273"></a>04273 <span class="keywordtype">void</span> scheme_deinit(scheme *sc) {
<a name="l04274"></a>04274 <span class="keywordtype">int</span> i;
<a name="l04275"></a>04275
<a name="l04276"></a>04276 sc-&gt;oblist=sc-&gt;NIL;
<a name="l04277"></a>04277 sc-&gt;global_env=sc-&gt;NIL;
<a name="l04278"></a>04278 dump_stack_free(sc);
<a name="l04279"></a>04279 sc-&gt;envir=sc-&gt;NIL;
<a name="l04280"></a>04280 sc-&gt;code=sc-&gt;NIL;
<a name="l04281"></a>04281 sc-&gt;args=sc-&gt;NIL;
<a name="l04282"></a>04282 sc-&gt;value=sc-&gt;NIL;
<a name="l04283"></a>04283 <span class="keywordflow">if</span>(is_port(sc-&gt;inport)) {
<a name="l04284"></a>04284 typeflag(sc-&gt;inport) = T_ATOM;
<a name="l04285"></a>04285 }
<a name="l04286"></a>04286 sc-&gt;inport=sc-&gt;NIL;
<a name="l04287"></a>04287 sc-&gt;outport=sc-&gt;NIL;
<a name="l04288"></a>04288 <span class="keywordflow">if</span>(is_port(sc-&gt;save_inport)) {
<a name="l04289"></a>04289 typeflag(sc-&gt;save_inport) = T_ATOM;
<a name="l04290"></a>04290 }
<a name="l04291"></a>04291 sc-&gt;save_inport=sc-&gt;NIL;
<a name="l04292"></a>04292 <span class="keywordflow">if</span>(is_port(sc-&gt;loadport)) {
<a name="l04293"></a>04293 typeflag(sc-&gt;loadport) = T_ATOM;
<a name="l04294"></a>04294 }
<a name="l04295"></a>04295 sc-&gt;loadport=sc-&gt;NIL;
<a name="l04296"></a>04296 sc-&gt;gc_verbose=0;
<a name="l04297"></a>04297 gc(sc,sc-&gt;NIL,sc-&gt;NIL);
<a name="l04298"></a>04298
<a name="l04299"></a>04299 <span class="keywordflow">for</span>(i=0; i&lt;=sc-&gt;last_cell_seg; i++) {
<a name="l04300"></a>04300 sc-&gt;free(sc-&gt;alloc_seg[i]);
<a name="l04301"></a>04301 }
<a name="l04302"></a>04302 }
<a name="l04303"></a>04303
<a name="l04304"></a>04304 <span class="keywordtype">void</span> scheme_load_file(scheme *sc, FILE *fin) {
<a name="l04305"></a>04305 dump_stack_reset(sc);
<a name="l04306"></a>04306 sc-&gt;envir = sc-&gt;global_env;
<a name="l04307"></a>04307 sc-&gt;file_i=0;
<a name="l04308"></a>04308 sc-&gt;load_stack[0].kind=port_input|port_file;
<a name="l04309"></a>04309 sc-&gt;load_stack[0].rep.stdio.file=fin;
<a name="l04310"></a>04310 sc-&gt;loadport=mk_port(sc,sc-&gt;load_stack);
<a name="l04311"></a>04311 sc-&gt;retcode=0;
<a name="l04312"></a>04312 <span class="keywordflow">if</span>(fin==stdin) {
<a name="l04313"></a>04313 sc-&gt;interactive_repl=1;
<a name="l04314"></a>04314 }
<a name="l04315"></a>04315 sc-&gt;inport=sc-&gt;loadport;
<a name="l04316"></a>04316 Eval_Cycle(sc, OP_T0LVL);
<a name="l04317"></a>04317 typeflag(sc-&gt;loadport)=T_ATOM;
<a name="l04318"></a>04318 <span class="keywordflow">if</span>(sc-&gt;retcode==0) {
<a name="l04319"></a>04319 sc-&gt;retcode=sc-&gt;nesting!=0;
<a name="l04320"></a>04320 }
<a name="l04321"></a>04321 }
<a name="l04322"></a>04322
<a name="l04323"></a>04323 <span class="keywordtype">void</span> scheme_load_string(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *cmd) {
<a name="l04324"></a>04324 dump_stack_reset(sc);
<a name="l04325"></a>04325 sc-&gt;envir = sc-&gt;global_env;
<a name="l04326"></a>04326 sc-&gt;file_i=0;
<a name="l04327"></a>04327 sc-&gt;load_stack[0].kind=port_input|port_string;
<a name="l04328"></a>04328 sc-&gt;load_stack[0].rep.string.start=(<span class="keywordtype">char</span>*)cmd; <span class="comment">/* This func respects const */</span>
<a name="l04329"></a>04329 sc-&gt;load_stack[0].rep.string.past_the_end=(<span class="keywordtype">char</span>*)cmd+strlen(cmd);
<a name="l04330"></a>04330 sc-&gt;load_stack[0].rep.string.curr=(<span class="keywordtype">char</span>*)cmd;
<a name="l04331"></a>04331 sc-&gt;loadport=mk_port(sc,sc-&gt;load_stack);
<a name="l04332"></a>04332 sc-&gt;retcode=0;
<a name="l04333"></a>04333 sc-&gt;interactive_repl=0;
<a name="l04334"></a>04334 sc-&gt;inport=sc-&gt;loadport;
<a name="l04335"></a>04335 Eval_Cycle(sc, OP_T0LVL);
<a name="l04336"></a>04336 typeflag(sc-&gt;loadport)=T_ATOM;
<a name="l04337"></a>04337 <span class="keywordflow">if</span>(sc-&gt;retcode==0) {
<a name="l04338"></a>04338 sc-&gt;retcode=sc-&gt;nesting!=0;
<a name="l04339"></a>04339 }
<a name="l04340"></a>04340 }
<a name="l04341"></a>04341
<a name="l04342"></a>04342 <span class="keywordtype">void</span> scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) {
<a name="l04343"></a>04343 pointer x;
<a name="l04344"></a>04344
<a name="l04345"></a>04345 x=find_slot_in_env(sc,envir,symbol,0);
<a name="l04346"></a>04346 <span class="keywordflow">if</span> (x != sc-&gt;NIL) {
<a name="l04347"></a>04347 set_slot_in_env(sc, x, value);
<a name="l04348"></a>04348 } <span class="keywordflow">else</span> {
<a name="l04349"></a>04349 new_slot_spec_in_env(sc, envir, symbol, value);
<a name="l04350"></a>04350 }
<a name="l04351"></a>04351 }
<a name="l04352"></a>04352
<a name="l04353"></a>04353 <span class="preprocessor">#if !STANDALONE</span>
<a name="l04354"></a>04354 <span class="preprocessor"></span><span class="keywordtype">void</span> scheme_apply0(scheme *sc, <span class="keyword">const</span> <span class="keywordtype">char</span> *procname) {
<a name="l04355"></a>04355 pointer carx=mk_symbol(sc,procname);
<a name="l04356"></a>04356 pointer cdrx=sc-&gt;NIL;
<a name="l04357"></a>04357
<a name="l04358"></a>04358 dump_stack_reset(sc);
<a name="l04359"></a>04359 sc-&gt;envir = sc-&gt;global_env;
<a name="l04360"></a>04360 sc-&gt;code = cons(sc,carx,cdrx);
<a name="l04361"></a>04361 sc-&gt;interactive_repl=0;
<a name="l04362"></a>04362 sc-&gt;retcode=0;
<a name="l04363"></a>04363 Eval_Cycle(sc,OP_EVAL);
<a name="l04364"></a>04364 }
<a name="l04365"></a>04365
<a name="l04366"></a>04366 <span class="keywordtype">void</span> scheme_call(scheme *sc, pointer func, pointer args) {
<a name="l04367"></a>04367 dump_stack_reset(sc);
<a name="l04368"></a>04368 sc-&gt;envir = sc-&gt;global_env;
<a name="l04369"></a>04369 sc-&gt;args = args;
<a name="l04370"></a>04370 sc-&gt;code = func;
<a name="l04371"></a>04371 sc-&gt;interactive_repl =0;
<a name="l04372"></a>04372 sc-&gt;retcode = 0;
<a name="l04373"></a>04373 Eval_Cycle(sc, OP_APPLY);
<a name="l04374"></a>04374 }
<a name="l04375"></a>04375 <span class="preprocessor">#endif</span>
<a name="l04376"></a>04376 <span class="preprocessor"></span>
<a name="l04377"></a>04377 <span class="comment">/* ========== Main ========== */</span>
<a name="l04378"></a>04378
<a name="l04379"></a>04379 <span class="preprocessor">#if STANDALONE</span>
<a name="l04380"></a>04380 <span class="preprocessor"></span>
<a name="l04381"></a>04381 <span class="preprocessor">#ifdef macintosh</span>
<a name="l04382"></a>04382 <span class="preprocessor"></span><span class="keywordtype">int</span> main()
<a name="l04383"></a>04383 {
<a name="l04384"></a>04384 <span class="keyword">extern</span> MacTS_main(<span class="keywordtype">int</span> argc, <span class="keywordtype">char</span> **argv);
<a name="l04385"></a>04385 <span class="keywordtype">char</span>** argv;
<a name="l04386"></a>04386 <span class="keywordtype">int</span> argc = ccommand(&amp;argv);
<a name="l04387"></a>04387 MacTS_main(argc,argv);
<a name="l04388"></a>04388 <span class="keywordflow">return</span> 0;
<a name="l04389"></a>04389 }
<a name="l04390"></a>04390 <span class="keywordtype">int</span> MacTS_main(<span class="keywordtype">int</span> argc, <span class="keywordtype">char</span> **argv) {
<a name="l04391"></a>04391 <span class="preprocessor">#else</span>
<a name="l04392"></a>04392 <span class="preprocessor"></span><span class="keywordtype">int</span> main(<span class="keywordtype">int</span> argc, <span class="keywordtype">char</span> **argv) {
<a name="l04393"></a>04393 <span class="preprocessor">#endif</span>
<a name="l04394"></a>04394 <span class="preprocessor"></span> scheme sc;
<a name="l04395"></a>04395 FILE *fin = 0;
<a name="l04396"></a>04396 <span class="keywordtype">char</span> *file_name=InitFile;
<a name="l04397"></a>04397 <span class="keywordtype">int</span> retcode;
<a name="l04398"></a>04398 <span class="keywordtype">int</span> isfile=1;
<a name="l04399"></a>04399
<a name="l04400"></a>04400 <span class="keywordflow">if</span>(argc==1) {
<a name="l04401"></a>04401 printf(banner);
<a name="l04402"></a>04402 }
<a name="l04403"></a>04403 <span class="keywordflow">if</span>(argc==2 &amp;&amp; strcmp(argv[1],<span class="stringliteral">"-?"</span>)==0) {
<a name="l04404"></a>04404 printf(<span class="stringliteral">"Usage: %s [-? | &lt;file1&gt; &lt;file2&gt; ... | -1 &lt;file&gt; &lt;arg1&gt; &lt;arg2&gt; ...]\n\tUse - as filename for stdin.\n"</span>,argv[0]);
<a name="l04405"></a>04405 <span class="keywordflow">return</span> 1;
<a name="l04406"></a>04406 }
<a name="l04407"></a>04407 <span class="keywordflow">if</span>(!scheme_init(&amp;sc)) {
<a name="l04408"></a>04408 fprintf(stderr,<span class="stringliteral">"Could not initialize!\n"</span>);
<a name="l04409"></a>04409 <span class="keywordflow">return</span> 2;
<a name="l04410"></a>04410 }
<a name="l04411"></a>04411 scheme_set_input_port_file(&amp;sc, stdin);
<a name="l04412"></a>04412 scheme_set_output_port_file(&amp;sc, stdout);
<a name="l04413"></a>04413 <span class="preprocessor">#if USE_DL</span>
<a name="l04414"></a>04414 <span class="preprocessor"></span> scheme_define(&amp;sc,sc.global_env,mk_symbol(&amp;sc,<span class="stringliteral">"load-extension"</span>),mk_foreign_func(&amp;sc, scm_load_ext));
<a name="l04415"></a>04415 <span class="preprocessor">#endif</span>
<a name="l04416"></a>04416 <span class="preprocessor"></span> argv++;
<a name="l04417"></a>04417 <span class="keywordflow">if</span>(access(file_name,0)!=0) {
<a name="l04418"></a>04418 <span class="keywordtype">char</span> *p=getenv(<span class="stringliteral">"TINYSCHEMEINIT"</span>);
<a name="l04419"></a>04419 <span class="keywordflow">if</span>(p!=0) {
<a name="l04420"></a>04420 file_name=p;
<a name="l04421"></a>04421 }
<a name="l04422"></a>04422 }
<a name="l04423"></a>04423 <span class="keywordflow">do</span> {
<a name="l04424"></a>04424 <span class="keywordflow">if</span>(strcmp(file_name,<span class="stringliteral">"-"</span>)==0) {
<a name="l04425"></a>04425 fin=stdin;
<a name="l04426"></a>04426 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(strcmp(file_name,<span class="stringliteral">"-1"</span>)==0 || strcmp(file_name,<span class="stringliteral">"-c"</span>)==0) {
<a name="l04427"></a>04427 pointer args=sc.NIL;
<a name="l04428"></a>04428 isfile=file_name[1]==<span class="charliteral">'1'</span>;
<a name="l04429"></a>04429 file_name=*argv++;
<a name="l04430"></a>04430 <span class="keywordflow">if</span>(strcmp(file_name,<span class="stringliteral">"-"</span>)==0) {
<a name="l04431"></a>04431 fin=stdin;
<a name="l04432"></a>04432 } <span class="keywordflow">else</span> <span class="keywordflow">if</span>(isfile) {
<a name="l04433"></a>04433 fin=fopen(file_name,<span class="stringliteral">"r"</span>);
<a name="l04434"></a>04434 }
<a name="l04435"></a>04435 <span class="keywordflow">for</span>(;*argv;argv++) {
<a name="l04436"></a>04436 pointer value=mk_string(&amp;sc,*argv);
<a name="l04437"></a>04437 args=cons(&amp;sc,value,args);
<a name="l04438"></a>04438 }
<a name="l04439"></a>04439 args=reverse_in_place(&amp;sc,sc.NIL,args);
<a name="l04440"></a>04440 scheme_define(&amp;sc,sc.global_env,mk_symbol(&amp;sc,<span class="stringliteral">"*args*"</span>),args);
<a name="l04441"></a>04441
<a name="l04442"></a>04442 } <span class="keywordflow">else</span> {
<a name="l04443"></a>04443 fin=fopen(file_name,<span class="stringliteral">"r"</span>);
<a name="l04444"></a>04444 }
<a name="l04445"></a>04445 <span class="keywordflow">if</span>(isfile &amp;&amp; fin==0) {
<a name="l04446"></a>04446 fprintf(stderr,<span class="stringliteral">"Could not open file %s\n"</span>,file_name);
<a name="l04447"></a>04447 } <span class="keywordflow">else</span> {
<a name="l04448"></a>04448 <span class="keywordflow">if</span>(isfile) {
<a name="l04449"></a>04449 scheme_load_file(&amp;sc,fin);
<a name="l04450"></a>04450 } <span class="keywordflow">else</span> {
<a name="l04451"></a>04451 scheme_load_string(&amp;sc,file_name);
<a name="l04452"></a>04452 }
<a name="l04453"></a>04453 <span class="keywordflow">if</span>(!isfile || fin!=stdin) {
<a name="l04454"></a>04454 <span class="keywordflow">if</span>(sc.retcode!=0) {
<a name="l04455"></a>04455 fprintf(stderr,<span class="stringliteral">"Errors encountered reading %s\n"</span>,file_name);
<a name="l04456"></a>04456 }
<a name="l04457"></a>04457 <span class="keywordflow">if</span>(isfile) {
<a name="l04458"></a>04458 fclose(fin);
<a name="l04459"></a>04459 }
<a name="l04460"></a>04460 }
<a name="l04461"></a>04461 }
<a name="l04462"></a>04462 file_name=*argv++;
<a name="l04463"></a>04463 } <span class="keywordflow">while</span>(file_name!=0);
<a name="l04464"></a>04464 <span class="keywordflow">if</span>(argc==1) {
<a name="l04465"></a>04465 scheme_load_file(&amp;sc,stdin);
<a name="l04466"></a>04466 }
<a name="l04467"></a>04467 retcode=sc.retcode;
<a name="l04468"></a>04468 scheme_deinit(&amp;sc);
<a name="l04469"></a>04469
<a name="l04470"></a>04470 <span class="keywordflow">return</span> retcode;
<a name="l04471"></a>04471 }
<a name="l04472"></a>04472
<a name="l04473"></a>04473 <span class="preprocessor">#endif</span>
</pre></div></div>
<hr size="1"><address style="text-align: right;"><small>Generated on Tue Aug 19 00:14:50 2008 for gerbv by&nbsp;
<a href="http://www.doxygen.org/index.html">
<img src="doxygen.png" alt="doxygen" align="middle" border="0"></a> 1.5.6 </small></address>
</body>
</html>
Reference in New Issue View Git Blame Copy Permalink