diff --git a/mps/example/scheme/scheme.c b/mps/example/scheme/scheme.c index 59938239c4a..31052efc747 100644 --- a/mps/example/scheme/scheme.c +++ b/mps/example/scheme/scheme.c @@ -16,20 +16,15 @@ * (define (church n f a) (if (eqv? n 0) a (church (- n 1) f (f a)))) * (church 1000 triangle 0) * - * This won't produce interesting results but it will cause a garbage + * This won't produce interesting results but it will cause garbage * collection cycles. Note that there's never any waiting for the MPS. * THAT'S THE POINT. * * To find the code that's particularly related to the MPS, search for %%MPS. * - * By the way, this interpreter originally just used `malloc` to allocate - * and had no garbage collector. Adapting it to use the MPS took - * approximately two hours (for an MPS developer :). - * * * MPS TO DO LIST * - make the symbol table weak to show how to use weak references - * - make Scheme ports finalized to show how to use finalization * - add Scheme operators for talking to the MPS, forcing GC etc. * - cross-references to documentation * - make an mps_perror @@ -109,9 +104,10 @@ enum { TYPE_PROMISE, TYPE_CHARACTER, TYPE_VECTOR, - TYPE_FWD2, /* two-word broken heart */ - TYPE_FWD, /* three-words and up broken heart */ - TYPE_PAD1 /* one-word padding object */ + TYPE_FWD2, /* two-word forwarding object */ + TYPE_FWD, /* three words and up forwarding object */ + TYPE_PAD1, /* one-word padding object */ + TYPE_PAD /* two words and up padding object */ }; typedef struct type_s { @@ -171,13 +167,13 @@ typedef struct vector_s { } vector_s; -/* fwd, fwd2, pad1 -- MPS forwarding and padding objects %%MPS +/* fwd2, fwd, pad1, pad -- MPS forwarding and padding objects %%MPS * * These object types are here to satisfy the MPS Format Protocol * for format variant "A". See [type mps_fmt_A_s in the reference * manual](../../reference/index.html#mps_fmt_A_s). * - * The MPS needs to be able to replace any object with forwarding object + * The MPS needs to be able to replace any object with a forwarding object * or [broken heart](http://www.memorymanagement.org/glossary/b.html#broken.heart) * and since the smallest normal object defined above is two words long, * we have two kinds of forwarding objects: FWD2 is exactly two words @@ -187,8 +183,8 @@ typedef struct vector_s { * The MPS needs to be able to pad out any area of memory that's a * multiple of the pool alignment. We've chosen an single word alignment * for this interpreter, so we have to have a special padding object, PAD1, - * for single words. For larger objects we can just use forwarding objects - * with NULL in their `fwd` fields. See `obj_isfwd` for details. + * for single words. For padding multiple words we use PAD objects with a + * size field. * * See obj_pad, obj_fwd etc. to see how these are used. */ @@ -208,6 +204,11 @@ typedef struct pad1_s { type_t type; /* TYPE_PAD1 */ } pad1_s; +typedef struct pad_s { + type_t type; /* TYPE_PAD */ + size_t size; /* total size of this object */ +} pad_s; + typedef union obj_u { type_s type; /* one of TYPE_* */ @@ -222,6 +223,7 @@ typedef union obj_u { vector_s vector; fwd2_s fwd2; fwd_s fwd; + pad_s pad; } obj_s; @@ -393,8 +395,10 @@ static void error(char *format, ...) * protocol. */ +#define ALIGNMENT sizeof(mps_word_t) + #define ALIGN(size) \ - (((size) + sizeof(mps_word_t) - 1) & ~(sizeof(mps_word_t) - 1)) + (((size) + ALIGNMENT - 1) & ~(ALIGNMENT - 1)) static obj_t make_pair(obj_t car, obj_t cdr) { @@ -830,8 +834,8 @@ static void print(obj_t obj, unsigned depth, FILE *stream) } break; default: - assert(0); - abort(); + assert(0); + abort(); } } @@ -2543,6 +2547,9 @@ static mps_res_t obj_scan(mps_ss_t ss, mps_addr_t base, mps_addr_t limit) case TYPE_PAD1: base = (char *)base + ALIGN(sizeof(pad1_s)); break; + case TYPE_PAD: + base = (char *)base + ALIGN(obj->pad.size); + break; default: assert(0); fprintf(stderr, "Unexpected object on the heap\n"); @@ -2604,6 +2611,9 @@ static mps_addr_t obj_skip(mps_addr_t base) case TYPE_FWD: base = (char *)base + ALIGN(obj->fwd.size); break; + case TYPE_PAD: + base = (char *)base + ALIGN(obj->pad.size); + break; case TYPE_PAD1: base = (char *)base + ALIGN(sizeof(pad1_s)); break; @@ -2669,8 +2679,8 @@ static void obj_fwd(mps_addr_t old, mps_addr_t new) * object that will be skipped by `obj_scan` or `obj_skip` but does * nothing else. Because we've chosen to align to single words, we may * have to pad a single word, so we have a special single-word padding - * object, `PAD1` for that purpose. Otherwise we can use forwarding - * objects with their `fwd` fields set to `NULL`. + * object, `PAD1` for that purpose. Otherwise we can use multi-word + * padding objects, `PAD`. */ static void obj_pad(mps_addr_t addr, size_t size) @@ -2679,31 +2689,13 @@ static void obj_pad(mps_addr_t addr, size_t size) assert(size >= ALIGN(sizeof(pad1_s))); if (size == ALIGN(sizeof(pad1_s))) { obj->type.type = TYPE_PAD1; - } else if (size == ALIGN(sizeof(fwd2_s))) { - obj->type.type = TYPE_FWD2; - obj->fwd2.fwd = NULL; } else { - obj->type.type = TYPE_FWD; - obj->fwd.fwd = NULL; - obj->fwd.size = size; + obj->type.type = TYPE_PAD; + obj->pad.size = size; } } -/* obj_copy -- object format copy method %%MPS - * - * The job of `obj_copy` is to make a copy of an object. - * TODO: Explain why this exists. - */ - -static void obj_copy(mps_addr_t old, mps_addr_t new) -{ - mps_addr_t limit = obj_skip(old); - size_t size = (char *)limit - (char *)old; - (void)memcpy(new, old, size); -} - - /* obj_fmt_s -- object format parameter structure %%MPS * * This is simply a gathering of the object format methods and the chosen @@ -2711,10 +2703,10 @@ static void obj_copy(mps_addr_t old, mps_addr_t new) */ struct mps_fmt_A_s obj_fmt_s = { - sizeof(mps_word_t), + ALIGNMENT, obj_scan, obj_skip, - obj_copy, + NULL, /* Obsolete copy method */ obj_fwd, obj_isfwd, obj_pad @@ -2761,7 +2753,7 @@ static void mps_chat(void) assert(b); /* we just checked there was one */ if (type == mps_message_type_gc_start()) { - printf("Collection %lu started.\n", (unsigned long)mps_collections(arena)); + printf("Collection started.\n"); printf(" Why: %s\n", mps_message_gc_start_why(arena, message)); printf(" Clock: %lu\n", (unsigned long)mps_message_clock(arena, message)); @@ -2907,7 +2899,14 @@ static void *start(void *p, size_t s) /* obj_gen_params -- initial setup for generational GC %%MPS * - * FIXME: explain this + * Each structure in this array describes one generation of objects. The + * two members are the capacity of the generation in kilobytes, and the + * mortality, the proportion of objects in the generation that you expect + * to survive a collection of that generation. + * + * These numbers are *hints* to the MPS that it may use to make decisions + * about when and what to collect: nothing will go wrong (other than + * suboptimal performance) if you make poor choices. */ static mps_gen_param_s obj_gen_params[] = { diff --git a/mps/license.txt b/mps/license.txt index 59e0818c857..5ee51a8f6de 100644 --- a/mps/license.txt +++ b/mps/license.txt @@ -9,48 +9,50 @@ open source. If the licensing terms aren't suitable for you (for example, you're developing a closed-source commercial product or a compiler run-time system) you can easily license the MPS under different terms from -Ravenbrook. Please write to us for more -information. +Ravenbrook. Please write to us at ``_ +for more information. -The open source license for the MPS is the [Sleepycat License][] also +The open source license for the MPS is the `Sleepycat License`_ also known as the "Berkeley Database License". This license is -[GPL compatible][] and [OSI approved][]. The MPS is "multi licensed" in +`GPL compatible`_ and `OSI approved`_. The MPS is "multi licensed" in a manner similar to MySQL. -[Sleepycat License]: https://en.wikipedia.org/wiki/Sleepycat_License -[GPL compatible]: http://www.gnu.org/licenses/license-list.html -[OSI approved]: http://opensource.org/licenses/sleepycat +.. _Sleepycat License: https://en.wikipedia.org/wiki/Sleepycat_License +.. _GPL compatible: http://www.gnu.org/licenses/license-list.html +.. _OSI approved: http://opensource.org/licenses/sleepycat License ------- -Copyright (C) 2001-2012 Ravenbrook Limited . +Copyright © 2001–2012 `Ravenbrook Limited `_. All rights reserved. This is the open source license for the Memory -Pool System, but it is not the only one. Contact Ravenbrook - if you would like a different license. +Pool System, but it is not the only one. Contact Ravenbrook at +``_ if you would like a different +license. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright -notice, this list of conditions and the following disclaimer. + notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright -notice, this list of conditions and the following disclaimer in the -documentation and/or other materials provided with the distribution. + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the + distribution. -3. Redistributions in any form must be accompanied by information on how -to obtain complete source code for this software and any -accompanying software that uses this software. The source code must -either be included in the distribution or be available for no more than -the cost of distribution plus a nominal fee, and must be freely -redistributable under reasonable conditions. For an executable file, -complete source code means the source code for all modules it contains. -It does not include source code for modules or files that typically -accompany the major components of the operating system on which the -executable file runs. +3. Redistributions in any form must be accompanied by information on + how to obtain complete source code for this software and any + accompanying software that uses this software. The source code + must either be included in the distribution or be available for no + more than the cost of distribution plus a nominal fee, and must be + freely redistributable under reasonable conditions. For an + executable file, complete source code means the source code for all + modules it contains. It does not include source code for modules + or files that typically accompany the major components of the + operating system on which the executable file runs. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED @@ -68,16 +70,12 @@ THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Exceptions ---------- -### Open Dylan +**Open Dylan** -Software that makes use of the Memory Pool System only via the Dylan -programming language using the Open Dylan implementation and any -accompanying software is exempt from clause 3 of the license, provided -that the Dylan program is not providing memory management services. For -the avoidance of doubt, this exemption does not apply to software -directly using a copy of the Memory Pool System received as part of the -Open Dylan source code. - ---- - -$Id$ + Software that makes use of the Memory Pool System only via the Dylan + programming language using the Open Dylan implementation and any + accompanying software is exempt from clause 3 of the license, provided + that the Dylan program is not providing memory management services. For + the avoidance of doubt, this exemption does not apply to software + directly using a copy of the Memory Pool System received as part of the + Open Dylan source code. diff --git a/mps/manual/build.txt b/mps/manual/build.txt index a89f495d44f..69c99271243 100644 --- a/mps/manual/build.txt +++ b/mps/manual/build.txt @@ -1,6 +1,6 @@ Building the Memory Pool System =============================== -Richard Brooksby, Ravenbrook Limited, 2012-09-05 + Introduction ------------ @@ -23,41 +23,44 @@ The MPS also comes with Makefiles and IDE project files for building libraries, tools, and tests. See "Building the MPS for development". -### Compiling for production +Compiling for production +........................ -In the simplest case, you can compile the MPS to an object file with just: +In the simplest case, you can compile the MPS to an object file with just:: cc -c mps.c (Unix/Mac OS X) cl /c mps.c (Windows) - + This will build a "hot" variety (for production) object file for use -with "mps.h". You can greatly improve performance by allowing global -optimization, for example: +with ``mps.h``. You can greatly improve performance by allowing global +optimization, for example:: cc -O2 -c mps.c (Unix/Mac OS X) cl /O2 /c mps.c (Windows) -### Compiling for debugging +Compiling for debugging +....................... You can get a "cool" variety MPS (with more internal checking, for -debugging and development) with: +debugging and development) with:: cc -g -DCONFIG_VAR_COOL -c mps.c cl /Zi /DCONFIG_VAR_COOL /c mps.c -### Optimizing for your object format +Optimizing for your object format +................................. -If you are using your own object format [ref?], you will also get +If you are using your own :term:`object format`, you will also get improved performance by allowing the compiler to do global optimisations between it and the MPS. So if your format implementation is in, say, -myformat.c, then you could make a file mymps.c containing +``myformat.c``, then you could make a file ``mymps.c`` containing:: #include "mps.c" #include "myformat.c" -then +then:: cc -O2 -c mymps.c (Unix/Mac OS X) cl /O2 /c mymps.c (Windows) @@ -65,17 +68,18 @@ then This will get your format code inlined with the MPS garbage collector. -### Compiling without the C library +Compiling without the C library +............................... If you're building the MPS for an environment without the standard C -library, you can exclude the "plinth" component of the MPS with +library, you can exclude the :ref:`topic-plinth` component of the MPS +with:: cc -DCONFIG_PLINTH_NONE -c mps.c cl /Gs /DCONFIG_PLINTH_NONE /c mps.c -but you must then provide your own implementation of -[mpslib.h](../code/mps.h). You can base this on the ANSI plinth in -[mpsliban.c](../code/mpsliban.c). +but you must then provide your own implementation of ``mpslib.h``. +You can base this on the ANSI plinth in ``mpsliban.c``. If you want to do anything beyond these simple cases, use the MPS build as described in the section "Building the MPS for development" below. @@ -90,162 +94,117 @@ use the MPS build. This uses makefiles or Xcode projects. [Coming soon, Microsoft Visual Studio solutions.] -### Prerequisites +Prerequisites +............. For Unix-like platforms you will need the GNU Make tool. Some platforms (such as Linux) have GNU Make as their default make tool. For others you will need to get and install it. (It's available free from -.) On FreeBSD this can be done as root -with `pkg_add -r gmake`. +``_.) On FreeBSD this can be done as root +with ``pkg_add -r gmake``. On Windows platforms the NMAKE tool is used. This comes with Microsoft Visual Studio C++ or the Microsoft Windows SDK. On Mac OS X the MPS is built using Xcode, either by opening -[mps.xcodeproj](../code/mps.xcodeproj) with the Xcode app, or using the -command-line "xcodebuild" tool, installed from Xcode -> Preferences -> -Downloads -> Components -> Command Line Tools. +``mps.xcodeproj`` with the Xcode app, or using the command-line +"xcodebuild" tool, installed from Xcode → Preferences → Downloads → +Components → Command Line Tools. -### Platforms +Platforms +......... -The MPS uses a six character platform code to express a combination of -OS/CPU architecture/compiler toolchain. Each 6 character code breaks -down into three groups of two characters, like this: +The MPS uses a six-character platform code to express a combination of +operating system, CPU architecture, and compiler toolchain. Each +six-character code breaks down into three pairs of characters, like +this:: - OSARCT + OSARCT -Where OS denotes the operating system, AR denotes the CPU architecture, -and CT denotes compiler toolchain. Here are the platforms that we -have regular access to and on which the MPS works well. +Where ``OS`` denotes the operating system, ``AR`` the CPU +architecture, and ``CT`` the compiler toolchain. Here are the +platforms that we have regular access to and on which the MPS works +well: - Makefile OS Architecture Compiler - - fri3gc.gmk FreeBSD Intel i386 GCC - fri6gc.gmk FreeBSD Intel x86_64 GCC - lii3gc.gmk Linux Intel i386 GCC - lii6gc.gmk Linux Intel x86_64 GCC - mps.xcodeproj Mac OS X i386 + x86_64 Clang - xci3gc.gmk Mac OS X i386 GCC (legacy) - w3i3mv.nmk Windows Intel i386 Microsoft C - w3i6mv.nmk Windows Intel x86_64 Microsoft C +========= ============= ============ ================= +OS Architecture Compiler Makefile +========= ============= ============ ================= +FreeBSD Intel i386 GCC ``fri3gc.gmk`` +FreeBSD Intel x86_64 GCC ``fri6gc.gmk`` +Linux Intel i386 GCC ``lii3gc.gmk`` +Linux Intel x86_64 GCC ``lii6gc.gmk`` +Mac OS X i386 + x86_64 Clang ``mps.xcodeproj`` +Mac OS X i386 GCC (legacy) ``xci3gc.gmk`` +Windows Intel i386 Microsoft C ``w3i3mv.nmk`` +Windows Intel x86_64 Microsoft C ``w3i6mv.nmk`` +========= ============= ============ ================= -Historically the MPS has worked on a much wider variety of platforms and -still could: IRIX, OSF/1 (Tru64), Solaris, SunOS, Classic Mac OS; MIPS, -PowerPC, ALPHA, SPARC v8, SPARC v9; Metrowerks Codewarrior, SunPro C, -Digital C, EGCS. If you are interested in support on any of these -platforms or any new platforms, please contact Ravenbrook -. +Historically, the MPS worked on a much wider variety of platforms, and +still could: IRIX, OSF/1 (Tru64), Solaris, SunOS, Classic Mac OS; +MIPS, PowerPC, ALPHA, SPARC v8, SPARC v9; Metrowerks Codewarrior, +SunPro C, Digital C, EGCS. If you are interested in support on any of +these platforms or any new platforms, please contact Ravenbrook at +`mps-questions@ravenbrook.com `_. -### Running make +Running make +............ -To build all MPS targets on Unix-like platforms, change to the "code" -directory and type: +To build all MPS targets on Unix-like platforms, change to the ``code`` +directory and type:: make -f -where "make" is the command for GNU Make. (Sometimes this will be -"gmake" or "gnumake".) +where ``make`` is the command for GNU Make. (Sometimes this will be +``gmake`` or ``gnumake``.) -To build just one target, type: +To build just one target, type:: make -f -To build a restricted set of targets for just one variety, type: +To build a restricted set of targets for just one variety, type:: make -f 'VARIETY=' -For example, to build just the "cool" variety of the "amcss" test on -FreeBSD: +For example, to build just the "cool" variety of the ``amcss`` test on +FreeBSD:: gmake -f fri3gc.gmk VARIETY=cool amcss On Windows platforms you need to run the "Visual Studio Command Prompt" -from the Start menu. Then type: +from the Start menu. Then type:: nmake /f w3i3mv.nmk (32-bit) nmake /f w3i6mv.nmk (64-bit) -You will need to switch your build environment between 32-bit and 64-bit -using Microsoft's `setenv` command, e.g. `setenv /x86` or `setenv /x64`. +You will need to switch your build environment between 32-bit and +64-bit using Microsoft's ``setenv`` command, for example, ``setenv +/x86`` or ``setenv /x64``. -To build just one target, type: +To build just one target, type:: nmake /f w3i3mv.nmk -On Mac OS X, you can build from the command line with: +On Mac OS X, you can build from the command line with:: xcodebuild On most platforms, the output of the build goes to a directory named -after the platform (e.g. `fri3gc`) so that you can share the source tree -across platforms. On Mac OS X the output goes in a directory called -`xc`. Building generates "mps.a" or "mps.lib" or equivalent, a -library of object code which you can link with your application, subject -to the MPS licensing conditions (see [license.txt](../license.txt). It -also generates a number of test programs, such as "amcss" (a stress test -for the Automatic Mostly-Copying pool class) and tools such as -"eventcnv" (for decoding telemetry logs). +after the platform (e.g. ``fri3gc``) so that you can share the source +tree across platforms. On Mac OS X the output goes in a directory +called ``xc``. Building generates ``mps.a`` or ``mps.lib`` or +equivalent, a library of object code which you can link with your +application, subject to the :ref:`MPS licensing conditions `. +It also generates a number of test programs, such as ``amcss`` (a +stress test for the Automatic Mostly-Copying pool class) and tools +such as ``eventcnv`` (for decoding telemetry logs). Installing the Memory Pool System --------------------------------- There is currently no automatic way to "install" the MPS, such as a -`make install` command. You can do this by copying the libraries built -by the make to, for example, `/usr/local/lib`, and all the headers -beginning with "mps" to `/usr/local/include`. - - -Document History ----------------- - -- 2012-09-05 RB First draft ready for version 1.110, based partly on - the old readme, which had grown far too long. - -- 2012-09-19 RB Tidying up a few points after feedback from GDR. - - -Copyright and Licence ---------------------- - -Copyright (C) 2001-2012 Ravenbrook Limited. All rights reserved. -. This is an open source license. Contact -Ravenbrook for commercial licensing options. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -1. Redistributions of source code must retain the above copyright -notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright -notice, this list of conditions and the following disclaimer in the -documentation and/or other materials provided with the distribution. - -3. Redistributions in any form must be accompanied by information on how -to obtain complete source code for this software and any -accompanying software that uses this software. The source code must -either be included in the distribution or be available for no more than -the cost of distribution plus a nominal fee, and must be freely -redistributable under reasonable conditions. For an executable file, -complete source code means the source code for all modules it contains. -It does not include source code for modules or files that typically -accompany the major components of the operating system on which the -executable file runs. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS -IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED -TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR -PURPOSE, OR NON-INFRINGEMENT, ARE DISCLAIMED. IN NO EVENT SHALL THE -COPYRIGHT HOLDERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, -INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT -NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF -USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON -ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF -THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -$Id$ +``make install`` command. You can do this by copying the libraries built +by the make to, for example, ``/usr/local/lib``, and all the headers +beginning with ``mps`` to ``/usr/local/include``. diff --git a/mps/manual/source/copyright.rst b/mps/manual/source/copyright.rst index d09914f2595..8ed6687bae3 100644 --- a/mps/manual/source/copyright.rst +++ b/mps/manual/source/copyright.rst @@ -1,44 +1,3 @@ -********************* -Copyright and licence -********************* +.. _license: -The Memory Pool System documentation is copyright © 1997–2012 by -`Ravenbrook Limited `_. All rights reserved. -This is an open source license. Contact Ravenbrook for commercial -licensing options. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the - distribution. - -3. Redistributions in any form must be accompanied by information on - how to obtain complete source code for this software and any - accompanying software that uses this software. The source code must - either be included in the distribution or be available for no more - than the cost of distribution plus a nominal fee, and must be freely - redistributable under reasonable conditions. For an executable file, - complete source code means the source code for all modules it - contains. It does not include source code for modules or files that - typically accompany the major components of the operating system on - which the executable file runs. - -**This software is provided by the copyright holders and contributors -"as is" and any express or implied warranties, including, but not -limited to, the implied warranties of merchantability, fitness for a -particular purpose, or non-infringement, are disclaimed. In no event -shall the copyright holders and contributors be liable for any direct, -indirect, incidental, special, exemplary, or consequential damages -(including, but not limited to, procurement of substitute goods or -services; loss of use, data, or profits; or business interruption) -however caused and on any theory of liability, whether in contract, -strict liability, or tort (including negligence or otherwise) arising -in any way out of the use of this software, even if advised of the -possibility of such damage.** +.. include:: ../../license.txt diff --git a/mps/manual/source/guide/build.rst b/mps/manual/source/guide/build.rst new file mode 100644 index 00000000000..d62e3267bbf --- /dev/null +++ b/mps/manual/source/guide/build.rst @@ -0,0 +1,3 @@ +.. _guide-build: + +.. include:: ../../build.txt diff --git a/mps/manual/source/guide/debug.rst b/mps/manual/source/guide/debug.rst index a676f7e6eab..4d2833690d3 100644 --- a/mps/manual/source/guide/debug.rst +++ b/mps/manual/source/guide/debug.rst @@ -2,9 +2,8 @@ .. _guide-debug: -====================== -Debugging with the MPS -====================== +Debugging with the Memory Pool System +===================================== * Messages. diff --git a/mps/manual/source/guide/index.rst b/mps/manual/source/guide/index.rst index bef39d37fc4..1d0c7a566a4 100644 --- a/mps/manual/source/guide/index.rst +++ b/mps/manual/source/guide/index.rst @@ -1,11 +1,12 @@ -********** -User guide -********** +.. _guide: + +Guide +***** .. toctree:: :numbered: - install + build overview lang perf diff --git a/mps/manual/source/guide/install.rst b/mps/manual/source/guide/install.rst deleted file mode 100644 index 317ee991f9d..00000000000 --- a/mps/manual/source/guide/install.rst +++ /dev/null @@ -1,6 +0,0 @@ -.. _guide-install: - -================== -Installing the MPS -================== - diff --git a/mps/manual/source/guide/lang.rst b/mps/manual/source/guide/lang.rst index 0632aa4c350..6f2d22fd448 100644 --- a/mps/manual/source/guide/lang.rst +++ b/mps/manual/source/guide/lang.rst @@ -2,9 +2,8 @@ .. _guide-lang: -========================================== -Garbage collecting a language with the MPS -========================================== +Garbage collecting a language with the Memory Pool System +========================================================= Have you written the lexer, parser, code generator and the runtime system for your programming language, and come to the realization that @@ -16,11 +15,10 @@ moving, generational garbage collection to the runtime system for a programming language. I'm assuming that you've downloaded and built the MPS (see the chapter -:ref:`guide-install`), and that you are familiar with the overall +:ref:`guide-build`), and that you are familiar with the overall architecture of the MPS (see the chapter :ref:`guide-overview`). ----------------------- The Scheme interpreter ---------------------- @@ -115,7 +113,6 @@ are :term:`dead` before their memory can be :term:`reclaimed `. And that task falls to the :term:`garbage collector`. ------------------------ Choosing an arena class ----------------------- @@ -180,7 +177,6 @@ some other value if it failed. :ref:`topic-arena`. ---------------------- Choosing a pool class --------------------- @@ -212,7 +208,6 @@ these features of the MPS. classes. ------------------------ Describing your objects ----------------------- @@ -624,7 +619,6 @@ code must be added to ``obj_scan`` and ``obj_skip``:: :ref:`topic-format`. ------------------ Generation chains ----------------- @@ -660,7 +654,6 @@ interpreter:: if (res != MPS_RES_OK) error("Couldn't create obj chain"); ------------------ Creating the pool ----------------- @@ -710,7 +703,6 @@ And finally the :term:`pool`:: if (res != MPS_RES_OK) error("Couldn't create obj pool"); ------ Roots ----- @@ -908,7 +900,6 @@ changes size:: .. _guide-lang-threads: -------- Threads ------- @@ -1009,7 +1000,6 @@ it now must be organized like this:: .. _guide-lang-allocation: ----------- Allocation ---------- @@ -1120,7 +1110,6 @@ we have to initialize the object again (most conveniently done via a :ref:`topic-allocation`. ------------------------ Maintaining consistency ----------------------- @@ -1162,7 +1151,6 @@ with tactics for tracking down the causes, appear in the chapter :ref:`guide-debug`. ----------- Tidying up ---------- @@ -1190,8 +1178,6 @@ Here's the tear-down code from the Scheme interpreter:: mps_arena_destroy(arena); - ----------- What next? ---------- diff --git a/mps/manual/source/guide/overview.rst b/mps/manual/source/guide/overview.rst index 6ff5613f8c0..51084d563be 100644 --- a/mps/manual/source/guide/overview.rst +++ b/mps/manual/source/guide/overview.rst @@ -1,7 +1,6 @@ .. _guide-overview: -=================== -Overview of the MPS -=================== +Overview of the Memory Pool System +================================== diff --git a/mps/manual/source/guide/perf.rst b/mps/manual/source/guide/perf.rst index e2832576ff1..c431f7f7363 100644 --- a/mps/manual/source/guide/perf.rst +++ b/mps/manual/source/guide/perf.rst @@ -2,8 +2,7 @@ .. _guide-perf: -============================== -Tuning the MPS for performance -============================== +Tuning the Memory Pool System for performance +============================================= See diff --git a/mps/manual/source/guide/scheme-after.c b/mps/manual/source/guide/scheme-after.c deleted file mode 100644 index 4e5084046a9..00000000000 --- a/mps/manual/source/guide/scheme-after.c +++ /dev/null @@ -1,3051 +0,0 @@ -/* scheme.c -- SCHEME INTERPRETER EXAMPLE FOR THE MEMORY POOL SYSTEM - * - * $Id$ - * Copyright (c) 2001-2012 Ravenbrook Limited. See end of file for license. - * - * This is a toy interpreter for a subset of the Scheme programming - * language . - * It is by no means the best or even the right way to implement Scheme, - * but it serves the purpose of showing how the Memory Pool System can be - * used as part of a programming language run-time system. - * - * To try it out, "make scheme" then - * - * $ ./scheme - * (define (triangle n) (if (eqv? n 0) 0 (+ n (triangle (- n 1))))) - * (define (church n f a) (if (eqv? n 0) a (church (- n 1) f (f a)))) - * (church 1000 triangle 0) - * - * This won't produce interesting results but it will cause garbage - * collection cycles. Note that there's never any waiting for the MPS. - * THAT'S THE POINT. - * - * To find the code that's particularly related to the MPS, search for %%MPS. - * - * - * MPS TO DO LIST - * - make the symbol table weak to show how to use weak references - * - make Scheme ports finalized to show how to use finalization - * - add Scheme operators for talking to the MPS, forcing GC etc. - * - cross-references to documentation - * - make an mps_perror - * - * - * SCHEME TO DO LIST - * - unbounded integers, other number types. - * - do, named let. - * - Quasiquote implementation is messy. - * - Lots of library. - * - \#foo unsatisfactory in read and print - */ - -#include -#include -#include -#include -#include -#include -#include -#include - -#include "mps.h" -#include "mpsavm.h" -#include "mpscamc.h" - - -/* LANGUAGE EXTENSION */ - -#define unless(c) if(!(c)) -#define LENGTH(array) (sizeof(array) / sizeof(array[0])) - - -/* CONFIGURATION PARAMETERS */ - - -#define SYMMAX ((size_t)255) /* max length of a symbol */ -#define MSGMAX ((size_t)255) /* max length of error message */ -#define STRMAX ((size_t)255) /* max length of a string */ - - -/* DATA TYPES */ - - -/* obj_t -- scheme object type - * - * obj_t is a pointer to a union, obj_u, which has members for - * each scheme representation. - * - * The obj_u also has a "type" member. Each representation - * structure also has a "type" field first. ANSI C guarantees - * that these type fields correspond [section?]. - * - * Objects are allocated by allocating one of the representation - * structures and casting the pointer to it to type obj_t. This - * allows objects of different sizes to be represented by the - * same type. - * - * To access an object, check its type by reading TYPE(obj), then - * access the fields of the representation, e.g. - * if(TYPE(obj) == TYPE_PAIR) fiddle_with(CAR(obj)); - */ - -typedef union obj_u *obj_t; - -typedef obj_t (*entry_t)(obj_t env, obj_t op_env, obj_t operator, obj_t rands); - -typedef int type_t; -enum { - TYPE_PAIR, - TYPE_INTEGER, - TYPE_SYMBOL, - TYPE_SPECIAL, - TYPE_OPERATOR, - TYPE_STRING, - TYPE_PORT, - TYPE_PROMISE, - TYPE_CHARACTER, - TYPE_VECTOR, - TYPE_FWD, /* three words and up forwarding object */ - TYPE_FWD2, /* two-word forwarding object */ - TYPE_PAD, /* two words and up padding object */ - TYPE_PAD1, /* one-word padding object */ -}; - -typedef struct type_s { - type_t type; -} type_s; - -typedef struct pair_s { - type_t type; /* TYPE_PAIR */ - obj_t car, cdr; /* first and second projections */ -} pair_s; - -typedef struct symbol_s { - type_t type; /* TYPE_SYMBOL */ - size_t length; /* length of symbol string (excl. NUL) */ - char string[1]; /* symbol string, NUL terminated */ -} symbol_s; - -typedef struct integer_s { - type_t type; /* TYPE_INTEGER */ - long integer; /* the integer */ -} integer_s; - -typedef struct special_s { - type_t type; /* TYPE_SPECIAL */ - char *name; /* printed representation, NUL terminated */ -} special_s; - -typedef struct operator_s { - type_t type; /* TYPE_OPERATOR */ - char *name; /* printed name, NUL terminated */ - entry_t entry; /* entry point -- see eval() */ - obj_t arguments, body; /* function arguments and code */ - obj_t env, op_env; /* closure environments */ -} operator_s; - -typedef struct string_s { - type_t type; /* TYPE_STRING */ - size_t length; /* number of chars in string */ - char string[1]; /* string, NUL terminated */ -} string_s; - -typedef struct port_s { - type_t type; /* TYPE_PORT */ - obj_t name; /* name of stream */ - FILE *stream; -} port_s; - -typedef struct character_s { - type_t type; /* TYPE_CHARACTER */ - char c; /* the character */ -} character_s; - -typedef struct vector_s { - type_t type; /* TYPE_VECTOR */ - size_t length; /* number of elements */ - obj_t vector[1]; /* vector elements */ -} vector_s; - - -/* fwd, fwd2, pad1 -- MPS forwarding and padding objects %%MPS - * - * These object types are here to satisfy the MPS Format Protocol - * for format variant "A". See [type mps_fmt_A_s in the reference - * manual](../../reference/index.html#mps_fmt_A_s). - * - * The MPS needs to be able to replace any object with forwarding object - * or [broken heart](http://www.memorymanagement.org/glossary/b.html#broken.heart) - * and since the smallest normal object defined above is two words long, - * we have two kinds of forwarding objects: FWD2 is exactly two words - * long, and FWD stores a size for larger objects. There are cleverer - * ways to do this with bit twiddling, of course. - * - * The MPS needs to be able to pad out any area of memory that's a - * multiple of the pool alignment. We've chosen an single word alignment - * for this interpreter, so we have to have a special padding object, PAD1, - * for single words. For larger objects we can just use forwarding objects - * with NULL in their `fwd` fields. See `obj_isfwd` for details. - * - * See obj_pad, obj_fwd etc. to see how these are used. - */ - -typedef struct fwd_s { - type_t type; /* TYPE_FWD */ - obj_t fwd; /* forwarded object */ - size_t size; /* total size of this object */ -} fwd_s; - -typedef struct fwd2_s { - type_t type; /* TYPE_FWD2 */ - obj_t fwd; /* forwarded object */ -} fwd2_s; - -typedef struct pad_s { - type_t type; /* TYPE_PAD */ - size_t size; /* total size of this object */ -} pad_s; - -typedef struct pad1_s { - type_t type; /* TYPE_PAD1 */ -} pad1_s; - - -typedef union obj_u { - type_s type; /* one of TYPE_* */ - pair_s pair; - symbol_s symbol; - integer_s integer; - special_s special; - operator_s operator; - string_s string; - port_s port; - character_s character; - vector_s vector; - fwd2_s fwd2; - fwd_s fwd; - pad_s pad; -} obj_s; - - -/* structure macros */ - -#define TYPE(obj) ((obj)->type.type) -#define CAR(obj) ((obj)->pair.car) -#define CDR(obj) ((obj)->pair.cdr) -#define CAAR(obj) CAR(CAR(obj)) -#define CADR(obj) CAR(CDR(obj)) -#define CDAR(obj) CDR(CAR(obj)) -#define CDDR(obj) CDR(CDR(obj)) -#define CADDR(obj) CAR(CDDR(obj)) -#define CDDDR(obj) CDR(CDDR(obj)) -#define CDDAR(obj) CDR(CDAR(obj)) -#define CADAR(obj) CAR(CDAR(obj)) - - -/* GLOBAL DATA */ - - -/* total -- total allocated bytes */ - -static size_t total; - - -/* symtab -- symbol table %%MPS - * - * The symbol table is a hash-table containing objects of TYPE_SYMBOL. - * When a string is "interned" it is looked up in the table, and added - * only if it is not there. This guarantees that all symbols which - * are equal are actually the same object. - * - * The symbol table is simply a malloc'd array of obj_t pointers. Since - * it's outside the MPS and refers to objects we want the MPS to keep - * alive, it must be declared to the MPS as a root. Search for - * occurrences of `symtab_root` to see how this is done. - */ - -static obj_t *symtab; -static size_t symtab_size; -static mps_root_t symtab_root; - - -/* special objects %%MPS - * - * These global variables are initialized to point to objects of - * TYPE_SPECIAL by main. They are used as markers for various - * special purposes. - * - * These static global variable refer to object allocated in the `obj_pool` - * and so they must also be declared to the MPS as roots. - * See `globals_scan`. - */ - -static obj_t obj_empty; /* (), the empty list */ -static obj_t obj_eof; /* end of file */ -static obj_t obj_error; /* error indicator */ -static obj_t obj_true; /* #t, boolean true */ -static obj_t obj_false; /* #f, boolean false */ -static obj_t obj_undefined; /* undefined result indicator */ -static obj_t obj_tail; /* tail recursion indicator */ - - -/* predefined symbols - * - * These global variables are initialized to point to interned - * objects of TYPE_SYMBOL. They have special meaning in the - * Scheme language, and are used by the evaluator to parse code. - */ - -static obj_t obj_quote; /* "quote" symbol */ -static obj_t obj_quasiquote; /* "quasiquote" symbol */ -static obj_t obj_lambda; /* "lambda" symbol */ -static obj_t obj_begin; /* "begin" symbol */ -static obj_t obj_else; /* "else" symbol */ -static obj_t obj_unquote; /* "unquote" symbol */ -static obj_t obj_unquote_splic; /* "unquote-splicing" symbol */ - - -/* error handler - * - * The error_handler variable is initialized to point at a - * jmp_buf to which the "error" function longjmps if there is - * any kind of error during evaluation. It can be set up by - * any enclosing function that wants to catch errors. There - * is a default error handler in main, in the read-eval-print - * loop. The error function also writes an error message - * into "error_message" before longjmping, and this can be - * displayed to the user when catching the error. - * - * [An error code should also be passed so that the error can - * be decoded by enclosing code.] - */ - -static jmp_buf *error_handler = NULL; -static char error_message[MSGMAX+1]; - - -/* MPS globals %%MPS - * - * These are global variables holding MPS values for use by the - * interpreter. In a more sophisticated integration some of these might - * be thread local. See `main` for where these are set up. - * - * `arena` is the global state of the MPS, and there's usually only one - * per process. - * - * `obj_pool` is the memory pool in which the Scheme objects are allocated. - * It is an instance of the Automatic Mostly Copying (AMC) pool class, which - * is a general-purpose garbage collector for use when there are formatted - * objects in the pool, but ambiguous references in thread stacks and - * registers. - * - * `obj_ap` is an Allocation Point that allows fast in-line non-locking - * allocation in a memory pool. This would usually be thread-local, but - * this interpreter is single-threaded. See `make_pair` etc. for how this - * is used with the reserve/commit protocol. - */ - -static mps_arena_t arena; /* the arena */ -static mps_pool_t obj_pool; /* pool for ordinary Scheme objects */ -static mps_ap_t obj_ap; /* allocation point used to allocate objects */ - - -/* SUPPORT FUNCTIONS */ - - -/* error -- throw an error condition - * - * The "error" function takes a printf-style format string - * and arguments, writes the message into error_message and - * longjmps to *error_handler. There must be a setjmp at - * the other end to catch the condition and display the - * message. - */ - -static void error(char *format, ...) -{ - va_list args; - - va_start(args, format); - vsnprintf(error_message, sizeof error_message, format, args); - va_end(args); - - if (error_handler) { - longjmp(*error_handler, 1); - } else { - fprintf(stderr, "Fatal error during initialization: %s\n", - error_message); - abort(); - } -} - - -/* make_* -- object constructors %%MPS - * - * Each object type has a function here that allocates an instance of - * that type. - * - * These functions illustrate the two-phase MPS Allocation Point - * Protocol with `reserve` and `commmit`. This protocol allows very fast - * in-line allocation without locking, but there is a very tiny chance that - * the object must be re-initialized. In nearly all cases, however, it's - * just a pointer bump. - * - * NOTE: We could reduce duplicated code here using macros, but we want to - * write these out because this is code to illustrate how to use the - * protocol. - */ - -#define ALIGN(size) \ - (((size) + sizeof(mps_word_t) - 1) & ~(sizeof(mps_word_t) - 1)) - -static obj_t make_pair(obj_t car, obj_t cdr) -{ - obj_t obj; - mps_addr_t addr; - /* When using the allocation point protocol it is up to the client - code to ensure that all requests are for aligned sizes, because in - nearly all cases `mps_reserve` is just an increment to a pointer. */ - size_t size = ALIGN(sizeof(pair_s)); - do { - mps_res_t res = mps_reserve(&addr, obj_ap, size); - if (res != MPS_RES_OK) error("out of memory in make_pair"); - obj = addr; - obj->pair.type = TYPE_PAIR; - CAR(obj) = car; - CDR(obj) = cdr; - /* `mps_commit` returns false on very rare occasions (when an MPS epoch - change has happened since reserve) but in those cases the object must - be re-initialized. It's therefore important not to do anything you - don't want to repeat between reserve and commit. Also, the shorter - the time between reserve and commit, the less likely commit is to - return false. */ - } while(!mps_commit(obj_ap, addr, size)); - total += sizeof(pair_s); - return obj; -} - -static obj_t make_integer(long integer) -{ - obj_t obj; - mps_addr_t addr; - size_t size = ALIGN(sizeof(integer_s)); - do { - mps_res_t res = mps_reserve(&addr, obj_ap, size); - if (res != MPS_RES_OK) error("out of memory in make_integer"); - obj = addr; - obj->integer.type = TYPE_INTEGER; - obj->integer.integer = integer; - } while(!mps_commit(obj_ap, addr, size)); - total += sizeof(integer_s); - return obj; -} - -static obj_t make_symbol(size_t length, char string[]) -{ - obj_t obj; - mps_addr_t addr; - size_t size = ALIGN(offsetof(symbol_s, string) + length+1); - do { - mps_res_t res = mps_reserve(&addr, obj_ap, size); - if (res != MPS_RES_OK) error("out of memory in make_symbol"); - obj = addr; - obj->symbol.type = TYPE_SYMBOL; - obj->symbol.length = length; - memcpy(obj->symbol.string, string, length+1); - } while(!mps_commit(obj_ap, addr, size)); - total += size; - return obj; -} - -static obj_t make_string(size_t length, char string[]) -{ - obj_t obj; - mps_addr_t addr; - size_t size = ALIGN(offsetof(string_s, string) + length+1); - do { - mps_res_t res = mps_reserve(&addr, obj_ap, size); - if (res != MPS_RES_OK) error("out of memory in make_string"); - obj = addr; - obj->string.type = TYPE_STRING; - obj->string.length = length; - memcpy(obj->string.string, string, length+1); - } while(!mps_commit(obj_ap, addr, size)); - total += size; - return obj; -} - -static obj_t make_special(char *string) -{ - obj_t obj; - mps_addr_t addr; - size_t size = ALIGN(sizeof(special_s)); - do { - mps_res_t res = mps_reserve(&addr, obj_ap, size); - if (res != MPS_RES_OK) error("out of memory in make_special"); - obj = addr; - obj->special.type = TYPE_SPECIAL; - obj->special.name = string; - } while(!mps_commit(obj_ap, addr, size)); - total += sizeof(special_s); - return obj; -} - -static obj_t make_operator(char *name, - entry_t entry, obj_t arguments, - obj_t body, obj_t env, obj_t op_env) -{ - obj_t obj; - mps_addr_t addr; - size_t size = ALIGN(sizeof(operator_s)); - do { - mps_res_t res = mps_reserve(&addr, obj_ap, size); - if (res != MPS_RES_OK) error("out of memory in make_operator"); - obj = addr; - obj->operator.type = TYPE_OPERATOR; - obj->operator.name = name; - obj->operator.entry = entry; - obj->operator.arguments = arguments; - obj->operator.body = body; - obj->operator.env = env; - obj->operator.op_env = op_env; - } while(!mps_commit(obj_ap, addr, size)); - total += sizeof(operator_s); - return obj; -} - -static obj_t make_port(obj_t name, FILE *stream) -{ - obj_t obj; - mps_addr_t addr; - size_t size = ALIGN(sizeof(port_s)); - do { - mps_res_t res = mps_reserve(&addr, obj_ap, size); - if (res != MPS_RES_OK) error("out of memory in make_operator"); - obj = addr; - obj->port.type = TYPE_PORT; - obj->port.name = name; - obj->port.stream = stream; - } while(!mps_commit(obj_ap, addr, size)); - total += sizeof(port_s); - return obj; -} - -static obj_t make_character(char c) -{ - obj_t obj; - mps_addr_t addr; - size_t size = ALIGN(sizeof(character_s)); - do { - mps_res_t res = mps_reserve(&addr, obj_ap, size); - if (res != MPS_RES_OK) error("out of memory in make_character"); - obj = addr; - obj->character.type = TYPE_CHARACTER; - obj->character.c = c; - } while(!mps_commit(obj_ap, addr, size)); - total += sizeof(character_s); - return obj; -} - -static obj_t make_vector(size_t length, obj_t fill) -{ - obj_t obj; - mps_addr_t addr; - size_t size = ALIGN(offsetof(vector_s, vector) + length * sizeof(obj_t)); - do { - mps_res_t res = mps_reserve(&addr, obj_ap, size); - size_t i; - if (res != MPS_RES_OK) error("out of memory in make_vector"); - obj = addr; - obj->vector.type = TYPE_VECTOR; - obj->vector.length = length; - for(i = 0; i < length; ++i) - obj->vector.vector[i] = fill; - } while(!mps_commit(obj_ap, addr, size)); - total += size; - return obj; -} - - -/* getnbc -- get next non-blank char from stream */ - -static int getnbc(FILE *stream) -{ - int c; - do - c = getc(stream); - while(isspace(c)); - return c; -} - - -/* isealpha -- test for "extended alphabetic" char - * - * Scheme symbols may contain any "extended alphabetic" - * character (see section 2.1 of R4RS). This function - * returns non-zero if a character is in the set of - * extended characters. - */ - -static int isealpha(int c) -{ - return strchr("+-.*/<=>!?:$%_&~^", c) != NULL; -} - - -/* hash -- hash a string to an unsigned long - * - * This hash function was derived (with permission) from - * Paul Haahr's hash in the most excellent rc 1.4. - */ - -static unsigned long hash(const char *s) { - char c; - unsigned long h=0; - - do { - c=*s++; if(c=='\0') break; else h+=(c<<17)^(c<<11)^(c<<5)^(c>>1); - c=*s++; if(c=='\0') break; else h^=(c<<14)+(c<<7)+(c<<4)+c; - c=*s++; if(c=='\0') break; else h^=(~c<<11)|((c<<3)^(c>>1)); - c=*s++; if(c=='\0') break; else h-=(c<<16)|(c<<9)|(c<<2)|(c&3); - } while(c); - - return h; -} - - -/* find -- find entry for symbol in symbol table - * - * Look for a symbol matching the string in the symbol table. - * If the symbol was found, returns the address of the symbol - * table entry which points to the symbol. Otherwise it - * either returns the address of a NULL entry into which the - * new symbol should be inserted, or NULL if the symbol table - * is full. - */ - -static obj_t *find(char *string) { - unsigned long i, h; - - h = hash(string) & (symtab_size-1); - i = h; - do { - if(symtab[i] == NULL || - strcmp(string, symtab[i]->symbol.string) == 0) - return &symtab[i]; - i = (i+h+1) & (symtab_size-1); - } while(i != h); - - return NULL; -} - - -/* rehash -- double size of symbol table */ - -static void rehash(void) { - obj_t *old_symtab = symtab; - unsigned old_symtab_size = symtab_size; - mps_root_t old_symtab_root = symtab_root; - unsigned i; - mps_res_t res; - - symtab_size *= 2; - symtab = malloc(sizeof(obj_t) * symtab_size); - if(symtab == NULL) error("out of memory"); - - /* Initialize the new table to NULL so that "find" will work. */ - for(i = 0; i < symtab_size; ++i) - symtab[i] = NULL; - - /* Once the symbol table is initialized with scannable references (NULL - in this case) we must register it as a root before we copy objects - across from the old symbol table. The MPS might be moving objects - in memory at any time, and will arrange that both copies are updated - atomically to the mutator (this interpreter). */ - res = mps_root_create_table(&symtab_root, arena, mps_rank_exact(), 0, - (mps_addr_t *)symtab, symtab_size); - if(res != MPS_RES_OK) error("Couldn't register new symtab root"); - - for(i = 0; i < old_symtab_size; ++i) - if(old_symtab[i] != NULL) { - obj_t *where = find(old_symtab[i]->symbol.string); - assert(where != NULL); /* new table shouldn't be full */ - assert(*where == NULL); /* shouldn't be in new table */ - *where = old_symtab[i]; - } - - mps_root_destroy(old_symtab_root); - free(old_symtab); -} - -/* union-find string in symbol table, rehashing if necessary */ -static obj_t intern(char *string) { - obj_t *where; - - where = find(string); - - if(where == NULL) { - rehash(); - where = find(string); - assert(where != NULL); /* shouldn't be full after rehash */ - } - - if(*where == NULL) /* symbol not found in table */ - *where = make_symbol(strlen(string), string); - - return *where; -} - - -static void print(obj_t obj, unsigned depth, FILE *stream) -{ - switch(TYPE(obj)) { - case TYPE_INTEGER: { - fprintf(stream, "%ld", obj->integer.integer); - } break; - - case TYPE_SYMBOL: { - fputs(obj->symbol.string, stream); - } break; - - case TYPE_SPECIAL: { - fputs(obj->special.name, stream); - } break; - - case TYPE_PORT: { - assert(TYPE(obj->port.name) == TYPE_STRING); - fprintf(stream, "#[port \"%s\"]", - obj->port.name->string.string); - } break; - - case TYPE_STRING: { - size_t i; - putc('"', stream); - for(i = 0; i < obj->string.length; ++i) { - char c = obj->string.string[i]; - switch(c) { - case '\\': fputs("\\\\", stream); break; - case '"': fputs("\\\"", stream); break; - default: putc(c, stream); break; - } - } - putc('"', stream); - } break; - - case TYPE_PROMISE: { - assert(CAR(obj) == obj_true || CAR(obj) == obj_false); - fprintf(stream, "#[%sevaluated promise ", - CAR(obj) == obj_false ? "un" : ""); - print(CDR(obj), depth - 1, stream); - putc(']', stream); - } break; - - case TYPE_PAIR: { - if(TYPE(CAR(obj)) == TYPE_SYMBOL && - TYPE(CDR(obj)) == TYPE_PAIR && - CDDR(obj) == obj_empty) { - if(CAR(obj) == obj_quote) { - putc('\'', stream); - if(depth == 0) - fputs("...", stream); - else - print(CADR(obj), depth - 1, stream); - break; - } - if(CAR(obj) == obj_quasiquote) { - putc('`', stream); - if(depth == 0) - fputs("...", stream); - else - print(CADR(obj), depth - 1, stream); - break; - } - if(CAR(obj) == obj_unquote) { - putc(',', stream); - if(depth == 0) - fputs("...", stream); - else - print(CADR(obj), depth - 1, stream); - break; - } - if(CAR(obj) == obj_unquote_splic) { - fputs(",@", stream); - if(depth == 0) - fputs("...", stream); - else - print(CADR(obj), depth - 1, stream); - break; - } - } - putc('(', stream); - if(depth == 0) - fputs("...", stream); - else { - for(;;) { - print(CAR(obj), depth - 1, stream); - obj = CDR(obj); - if(TYPE(obj) != TYPE_PAIR) break; - putc(' ', stream); - } - if(obj != obj_empty) { - fputs(" . ", stream); - print(obj, depth - 1, stream); - } - } - putc(')', stream); - } break; - - case TYPE_VECTOR: { - fputs("#(", stream); - if(depth == 0) - fputs("...", stream); - else { - size_t i; - for(i = 0; i < obj->vector.length; ++i) { - if(i > 0) putc(' ', stream); - print(obj->vector.vector[i], depth - 1, stream); - } - } - putc(')', stream); - } break; - - case TYPE_OPERATOR: { - fprintf(stream, "#[operator \"%s\" %p %p ", - obj->operator.name, - (void *)obj, - (void *)obj->operator.entry); - if(depth == 0) - fputs("...", stream); - else { - print(obj->operator.arguments, depth - 1, stream); - putc(' ', stream); - print(obj->operator.body, depth - 1, stream); - putc(' ', stream); - print(obj->operator.env, depth - 1, stream); - putc(' ', stream); - print(obj->operator.op_env, depth - 1, stream); - } - putc(']', stream); - } break; - - case TYPE_CHARACTER: { - fprintf(stream, "#\\%c", obj->character.c); - } break; - - default: - assert(0); - abort(); - } -} - - -static obj_t read_integer(FILE *stream, int c) -{ - long integer = 0; - - do { - integer = integer*10 + c-'0'; - c = getc(stream); - } while(isdigit(c)); - ungetc(c, stream); - - return make_integer(integer); -} - - -static obj_t read_symbol(FILE *stream, int c) -{ - int length = 0; - char string[SYMMAX+1]; - - do { - string[length++] = tolower(c); - c = getc(stream); - } while(length < SYMMAX && (isalnum(c) || isealpha(c))); - - if(isalnum(c) || isealpha(c)) - error("read: symbol too long"); - - string[length] = '\0'; - - ungetc(c, stream); - - return intern(string); -} - - -static obj_t read_string(FILE *stream, int c) -{ - int length = 0; - char string[STRMAX+1]; - - for(;;) { - c = getc(stream); - if(c == EOF) - error("read: end of file during string"); - if(c == '"') break; - if(length >= STRMAX) - error("read: string too long"); - if(c == '\\') { - c = getc(stream); - switch(c) { - case '\\': break; - case '"': break; - case 'n': c = '\n'; break; - case 't': c = '\t'; break; - case EOF: - error("read: end of file in escape sequence in string"); - default: - error("read: unknown escape '%c'", c); - } - } - string[length++] = c; - } - - string[length] = '\0'; - - return make_string(length, string); -} - - -static obj_t read(FILE *stream); - - -static obj_t read_quote(FILE *stream, int c) -{ - return make_pair(obj_quote, make_pair(read(stream), obj_empty)); -} - - -static obj_t read_quasiquote(FILE *stream, int c) -{ - return make_pair(obj_quasiquote, make_pair(read(stream), obj_empty)); -} - - -static obj_t read_unquote(FILE *stream, int c) -{ - c = getc(stream); - if(c == '@') - return make_pair(obj_unquote_splic, make_pair(read(stream), obj_empty)); - ungetc(c, stream); - return make_pair(obj_unquote, make_pair(read(stream), obj_empty)); -} - - -static obj_t read_list(FILE *stream, int c) -{ - obj_t list, new, end; - - list = obj_empty; - - for(;;) { - c = getnbc(stream); - if(c == ')' || c == '.') break; - ungetc(c, stream); - new = make_pair(read(stream), obj_empty); - if(list == obj_empty) { - list = new; - end = new; - } else { - CDR(end) = new; - end = new; - } - } - - if(c == '.') { - if(list == obj_empty) - error("read: unexpected dot"); - CDR(end) = read(stream); - c = getnbc(stream); - } - - if(c != ')') - error("read: expected close parenthesis"); - - return list; -} - - -static obj_t list_to_vector(obj_t list) -{ - size_t i; - obj_t l, vector; - i = 0; - l = list; - while(TYPE(l) == TYPE_PAIR) { - ++i; - l = CDR(l); - } - if(l != obj_empty) - return obj_error; - vector = make_vector(i, obj_undefined); - i = 0; - l = list; - while(TYPE(l) == TYPE_PAIR) { - vector->vector.vector[i] = CAR(l); - ++i; - l = CDR(l); - } - return vector; -} - - -static obj_t read_special(FILE *stream, int c) -{ - c = getnbc(stream); - switch(tolower(c)) { - case 't': return obj_true; - case 'f': return obj_false; - case '\\': { /* character (R4RS 6.6) */ - c = getc(stream); - if(c == EOF) - error("read: end of file reading character literal"); - return make_character(c); - } - case '(': { /* vector (R4RS 6.8) */ - obj_t list = read_list(stream, c); - obj_t vector = list_to_vector(list); - if(vector == obj_error) - error("read: illegal vector syntax"); - return vector; - } - } - error("read: unknown special '%c'", c); - return obj_error; -} - - -static obj_t read(FILE *stream) -{ - int c; - - c = getnbc(stream); - if(c == EOF) return obj_eof; - - if(isdigit(c)) - return read_integer(stream, c); - - switch(c) { - case '\'': return read_quote(stream, c); - case '`': return read_quasiquote(stream, c); - case ',': return read_unquote(stream, c); - case '(': return read_list(stream, c); - case '#': return read_special(stream, c); - case '"': return read_string(stream, c); - case '-': case '+': { - int next = getc(stream); - if(isdigit(next)) { - obj_t integer = read_integer(stream, next); - if(c == '-') - integer->integer.integer = -integer->integer.integer; - return integer; - } - ungetc(next, stream); - } break; /* fall through to read as symbol */ - } - - if(isalpha(c) || isealpha(c)) - return read_symbol(stream, c); - - error("read: illegal char '%c'", c); - return obj_error; -} - - -/* lookup_in_frame -- look up a symbol in single frame - * - * Search a single frame of the environment for a symbol binding. - */ - -static obj_t lookup_in_frame(obj_t frame, obj_t symbol) -{ - while(frame != obj_empty) { - assert(TYPE(frame) == TYPE_PAIR); - assert(TYPE(CAR(frame)) == TYPE_PAIR); - assert(TYPE(CAAR(frame)) == TYPE_SYMBOL); - if(CAAR(frame) == symbol) - return CAR(frame); - frame = CDR(frame); - } - return obj_undefined; -} - - -/* lookup -- look up symbol in environment - * - * Search an entire environment for a binding of a symbol. - */ - -static obj_t lookup(obj_t env, obj_t symbol) -{ - obj_t binding; - while(env != obj_empty) { - assert(TYPE(env) == TYPE_PAIR); - binding = lookup_in_frame(CAR(env), symbol); - if(binding != obj_undefined) - return binding; - env = CDR(env); - } - return obj_undefined; -} - - -/* define -- define symbol in environment - * - * In Scheme, define will actually rebind (i.e. set) a symbol in the - * same frame of the environment, or add a binding if it wasn't already - * set. This has the effect of making bindings local to functions - * (see how entry_interpret adds an empty frame to the environments), - * allowing recursion, and allowing redefinition at the top level. - * See R4R2 section 5.2 for details. - */ - -static void define(obj_t env, obj_t symbol, obj_t value) -{ - obj_t binding; - assert(TYPE(env) == TYPE_PAIR); /* always at least one frame */ - binding = lookup_in_frame(CAR(env), symbol); - if(binding != obj_undefined) - CDR(binding) = value; - else - CAR(env) = make_pair(make_pair(symbol, value), CAR(env)); -} - - -static obj_t eval(obj_t env, obj_t op_env, obj_t exp); - -static obj_t eval(obj_t env, obj_t op_env, obj_t exp) -{ - for(;;) { - obj_t operator; - obj_t result; - - /* self-evaluating */ - if(TYPE(exp) == TYPE_INTEGER || - (TYPE(exp) == TYPE_SPECIAL && exp != obj_empty) || - TYPE(exp) == TYPE_STRING || - TYPE(exp) == TYPE_CHARACTER) - return exp; - - /* symbol lookup */ - if(TYPE(exp) == TYPE_SYMBOL) { - obj_t binding = lookup(env, exp); - if(binding == obj_undefined) - error("eval: unbound symbol \"%s\"", exp->symbol.string); - return CDR(binding); - } - - if(TYPE(exp) != TYPE_PAIR) { - error("eval: unknown syntax"); - return obj_error; - } - - /* apply operator or function */ - if(TYPE(CAR(exp)) == TYPE_SYMBOL) { - obj_t binding = lookup(op_env, CAR(exp)); - if(binding != obj_undefined) { - operator = CDR(binding); - assert(TYPE(operator) == TYPE_OPERATOR); - result = (*operator->operator.entry)(env, op_env, operator, CDR(exp)); - goto found; - } - } - operator = eval(env, op_env, CAR(exp)); - unless(TYPE(operator) == TYPE_OPERATOR) - error("eval: application of non-function"); - result = (*operator->operator.entry)(env, op_env, operator, CDR(exp)); - - found: - if (!(TYPE(result) == TYPE_PAIR && CAR(result) == obj_tail)) - return result; - - env = CADR(result); - op_env = CADDR(result); - exp = CAR(CDDDR(result)); - } -} - - -/* OPERATOR UTILITIES */ - - -/* eval_list -- evaluate list of expressions giving list of results - * - * eval_list evaluates a list of expresions and yields a list of their - * results, in order. If the list is badly formed, an error is thrown - * using the message given. - */ - -static obj_t eval_list(obj_t env, obj_t op_env, obj_t list, char *message) -{ - obj_t result, end, pair; - result = obj_empty; - while(list != obj_empty) { - if(TYPE(list) != TYPE_PAIR) - error(message); - pair = make_pair(eval(env, op_env, CAR(list)), obj_empty); - if(result == obj_empty) - result = pair; - else - CDR(end) = pair; - end = pair; - list = CDR(list); - } - return result; -} - - -/* eval_args1 -- evaluate some operator arguments - * - * See eval_args and eval_args_rest for usage. - */ - -static obj_t eval_args1(char *name, obj_t env, obj_t op_env, - obj_t operands, unsigned n, va_list args) -{ - unsigned i; - for(i = 0; i < n; ++i) { - unless(TYPE(operands) == TYPE_PAIR) - error("eval: too few arguments to %s", name); - *va_arg(args, obj_t *) = eval(env, op_env, CAR(operands)); - operands = CDR(operands); - } - return operands; -} - - -/* eval_args -- evaluate operator arguments without rest list - * - * eval_args evaluates the first "n" expressions from the list of - * expressions in "operands", returning the rest of the operands - * unevaluated. It puts the results of evaluation in the addresses - * passed in the vararg list. If the operands list is badly formed - * an error is thrown using the operator name passed. For example: - * - * eval_args("foo", env, op_env, operands, 2, &arg1, &arg2); - */ - -static void eval_args(char *name, obj_t env, obj_t op_env, - obj_t operands, unsigned n, ...) -{ - va_list args; - va_start(args, n); - operands = eval_args1(name, env, op_env, operands, n, args); - unless(operands == obj_empty) - error("eval: too many arguments to %s", name); - va_end(args); -} - - -/* eval_args_rest -- evaluate operator arguments with rest list - * - * eval_args_rest evaluates the first "n" expressions from the list of - * expressions in "operands", then evaluates the rest of the operands - * using eval_list and puts the result at *restp. It puts the results - * of evaluating the first "n" operands in the addresses - * passed in the vararg list. If the operands list is badly formed - * an error is thrown using the operator name passed. For example: - * - * eval_args_rest("foo", env, op_env, operands, &rest, 2, &arg1, &arg2); - */ - -static void eval_args_rest(char *name, obj_t env, obj_t op_env, - obj_t operands, obj_t *restp, unsigned n, ...) -{ - va_list args; - va_start(args, n); - operands = eval_args1(name, env, op_env, operands, n, args); - va_end(args); - *restp = eval_list(env, op_env, operands, "eval: badly formed argument list"); -} - - -/* eval_tail -- return an object that will cause eval to loop - * - * Rather than calling `eval` an operator can return a special object that - * causes a calling `eval` to loop, avoiding using up a C stack frame. - * This implements tail recursion (in a simple way). - */ - -static obj_t eval_tail(obj_t env, obj_t op_env, obj_t exp) -{ - return make_pair(obj_tail, - make_pair(env, - make_pair(op_env, - make_pair(exp, - obj_empty)))); -} - - -/* eval_body -- evaluate a list of expressions, returning last result - * - * This is used for the bodies of forms such as let, begin, etc. where - * a list of expressions is allowed. - */ - -static obj_t eval_body(obj_t env, obj_t op_env, obj_t operator, obj_t body) -{ - for (;;) { - if (TYPE(body) != TYPE_PAIR) - error("%s: illegal expression list", operator->operator.name); - if (CDR(body) == obj_empty) - return eval_tail(env, op_env, CAR(body)); - (void)eval(env, op_env, CAR(body)); - body = CDR(body); - } -} - - -/* BUILT-IN OPERATORS */ - - -/* entry_interpret -- interpreted function entry point - * - * When a function is made using lambda (see entry_lambda) an operator - * is created with entry_interpret as its entry point, and the arguments - * and body of the function. The entry_interpret function evaluates - * the operands of the function and binds them to the argument names - * in a new frame added to the lambda's closure environment. It then - * evaluates the body in that environment, executing the function. - */ - -static obj_t entry_interpret(obj_t env, obj_t op_env, obj_t operator, obj_t operands) -{ - obj_t arguments, fun_env, fun_op_env; - - assert(TYPE(operator) == TYPE_OPERATOR); - - /* Make a new frame so that bindings are local to the function. */ - /* Arguments will be bound in this new frame. */ - fun_env = make_pair(obj_empty, operator->operator.env); - fun_op_env = make_pair(obj_empty, operator->operator.op_env); - - arguments = operator->operator.arguments; - while(operands != obj_empty) { - if(arguments == obj_empty) - error("eval: function applied to too many arguments"); - if(TYPE(arguments) == TYPE_SYMBOL) { - define(fun_env, arguments, - eval_list(env, op_env, operands, "eval: badly formed argument list")); - operands = obj_empty; - arguments = obj_empty; - } else { - assert(TYPE(arguments) == TYPE_PAIR && - TYPE(CAR(arguments)) == TYPE_SYMBOL); - define(fun_env, - CAR(arguments), - eval(env, op_env, CAR(operands))); - operands = CDR(operands); - arguments = CDR(arguments); - } - } - if(arguments != obj_empty) - error("eval: function applied to too few arguments"); - - return eval_tail(fun_env, fun_op_env, operator->operator.body); -} - - -/* entry_quote -- return operands unevaluated - * - * In Scheme, (quote foo) evaluates to foo (i.e. foo is not evaluated). - * See R4RS 4.1.2. The reader expands "'x" to "(quote x)". - */ - -static obj_t entry_quote(obj_t env, obj_t op_env, obj_t operator, obj_t operands) -{ - unless(TYPE(operands) == TYPE_PAIR && - CDR(operands) == obj_empty) - error("%s: illegal syntax", operator->operator.name); - return CAR(operands); -} - - -/* entry_define -- bind a symbol in the top frame of the environment - * - * In Scheme, "(define )" evaluates expressions - * and binds it to symbol in the top frame of the environment (see - * R4RS 5.2). This code also allows the non-essential syntax for - * define, "(define ( ) )" as a short-hand for - * "(define (lambda () ))". - */ - -static obj_t entry_define(obj_t env, obj_t op_env, obj_t operator, obj_t operands) -{ - obj_t symbol, value; - unless(TYPE(operands) == TYPE_PAIR && - TYPE(CDR(operands)) == TYPE_PAIR && - CDDR(operands) == obj_empty) - error("%s: illegal syntax", operator->operator.name); - if(TYPE(CAR(operands)) == TYPE_SYMBOL) { - symbol = CAR(operands); - value = eval(env, op_env, CADR(operands)); - } else if(TYPE(CAR(operands)) == TYPE_PAIR && - TYPE(CAAR(operands)) == TYPE_SYMBOL) { - symbol = CAAR(operands); - value = eval(env, op_env, - make_pair(obj_lambda, - make_pair(CDAR(operands), CDR(operands)))); - } else - error("%s: applied to binder", operator->operator.name); - define(env, symbol, value); - return symbol; -} - - -/* entry_if -- one- or two-armed conditional - * - * "(if )" and "(if )". - * See R4RS 4.1.5. - */ - -static obj_t entry_if(obj_t env, obj_t op_env, obj_t operator, obj_t operands) -{ - obj_t test; - unless(TYPE(operands) == TYPE_PAIR && - TYPE(CDR(operands)) == TYPE_PAIR && - (CDDR(operands) == obj_empty || - (TYPE(CDDR(operands)) == TYPE_PAIR && - CDDDR(operands) == obj_empty))) - error("%s: illegal syntax", operator->operator.name); - test = eval(env, op_env, CAR(operands)); - /* Anything which is not #f counts as true [R4RS 6.1]. */ - if(test != obj_false) - return eval_tail(env, op_env, CADR(operands)); - if(TYPE(CDDR(operands)) == TYPE_PAIR) - return eval_tail(env, op_env, CADDR(operands)); - return obj_undefined; -} - - -/* entry_cond -- general conditional - * - * "(cond ( ...) ( ...) ... [(else ...)])" - */ - -static obj_t entry_cond(obj_t env, obj_t op_env, obj_t operator, obj_t operands) -{ - unless(TYPE(operands) == TYPE_PAIR) - error("%s: illegal syntax", operator->operator.name); - while(TYPE(operands) == TYPE_PAIR) { - obj_t clause = CAR(operands); - obj_t result; - unless(TYPE(clause) == TYPE_PAIR && - TYPE(CDR(clause)) == TYPE_PAIR) - error("%s: illegal clause syntax", operator->operator.name); - if(CAR(clause) == obj_else) { - unless(CDR(operands) == obj_empty) - error("%s: else clause must come last", operator->operator.name); - result = obj_true; - } else - result = eval(env, op_env, CAR(clause)); - if(result != obj_false) { - if (CDR(clause) == obj_empty) - return result; - return eval_body(env, op_env, operator, CDR(clause)); - } - operands = CDR(operands); - } - return obj_undefined; -} - - -/* entry_and -- (and ...) */ - -static obj_t entry_and(obj_t env, obj_t op_env, obj_t operator, obj_t operands) -{ - obj_t test; - if (operands == obj_empty) - return obj_true; - do { - if (TYPE(operands) != TYPE_PAIR) - error("%s: illegal syntax", operator->operator.name); - if (CDR(operands) == obj_empty) - return eval_tail(env, op_env, CAR(operands)); - test = eval(env, op_env, CAR(operands)); - operands = CDR(operands); - } while (test != obj_false); - return test; -} - - -/* entry_or -- (or ...) */ - -static obj_t entry_or(obj_t env, obj_t op_env, obj_t operator, obj_t operands) -{ - obj_t test; - if (operands == obj_empty) - return obj_false; - do { - if (TYPE(operands) != TYPE_PAIR) - error("%s: illegal syntax", operator->operator.name); - if (CDR(operands) == obj_empty) - return eval_tail(env, op_env, CAR(operands)); - test = eval(env, op_env, CAR(operands)); - operands = CDR(operands); - } while (test == obj_false); - return test; -} - - -/* entry_let -- (let ) */ -/* TODO: Too much common code with let* */ - -static obj_t entry_let(obj_t env, obj_t op_env, obj_t operator, obj_t operands) -{ - obj_t inner_env, bindings; - unless(TYPE(operands) == TYPE_PAIR && - TYPE(CDR(operands)) == TYPE_PAIR) - error("%s: illegal syntax", operator->operator.name); - inner_env = make_pair(obj_empty, env); /* TODO: common with interpret */ - bindings = CAR(operands); - while(TYPE(bindings) == TYPE_PAIR) { - obj_t binding = CAR(bindings); - unless(TYPE(binding) == TYPE_PAIR && - TYPE(CAR(binding)) == TYPE_SYMBOL && - TYPE(CDR(binding)) == TYPE_PAIR && - CDDR(binding) == obj_empty) - error("%s: illegal binding", operator->operator.name); - define(inner_env, CAR(binding), eval(env, op_env, CADR(binding))); - bindings = CDR(bindings); - } - if(bindings != obj_empty) - error("%s: illegal bindings list", operator->operator.name); - return eval_body(inner_env, op_env, operator, CDR(operands)); -} - - -/* entry_let_star -- (let* ) */ -/* TODO: Too much common code with let */ - -static obj_t entry_let_star(obj_t env, obj_t op_env, obj_t operator, obj_t operands) -{ - obj_t inner_env, bindings; - unless(TYPE(operands) == TYPE_PAIR && - TYPE(CDR(operands)) == TYPE_PAIR) - error("%s: illegal syntax", operator->operator.name); - inner_env = make_pair(obj_empty, env); /* TODO: common with interpret */ - bindings = CAR(operands); - while(TYPE(bindings) == TYPE_PAIR) { - obj_t binding = CAR(bindings); - unless(TYPE(binding) == TYPE_PAIR && - TYPE(CAR(binding)) == TYPE_SYMBOL && - TYPE(CDR(binding)) == TYPE_PAIR && - CDDR(binding) == obj_empty) - error("%s: illegal binding", operator->operator.name); - define(inner_env, CAR(binding), eval(inner_env, op_env, CADR(binding))); - bindings = CDR(bindings); - } - if(bindings != obj_empty) - error("%s: illegal bindings list", operator->operator.name); - return eval_body(inner_env, op_env, operator, CDR(operands)); -} - - -/* entry_letrec -- (letrec ) */ -/* TODO: Too much common code with let and let* */ - -static obj_t entry_letrec(obj_t env, obj_t op_env, obj_t operator, obj_t operands) -{ - obj_t inner_env, bindings; - unless(TYPE(operands) == TYPE_PAIR && - TYPE(CDR(operands)) == TYPE_PAIR) - error("%s: illegal syntax", operator->operator.name); - inner_env = make_pair(obj_empty, env); /* TODO: common with interpret */ - bindings = CAR(operands); - while(TYPE(bindings) == TYPE_PAIR) { - obj_t binding = CAR(bindings); - unless(TYPE(binding) == TYPE_PAIR && - TYPE(CAR(binding)) == TYPE_SYMBOL && - TYPE(CDR(binding)) == TYPE_PAIR && - CDDR(binding) == obj_empty) - error("%s: illegal binding", operator->operator.name); - define(inner_env, CAR(binding), obj_undefined); - bindings = CDR(bindings); - } - if(bindings != obj_empty) - error("%s: illegal bindings list", operator->operator.name); - bindings = CAR(operands); - while(TYPE(bindings) == TYPE_PAIR) { - obj_t binding = CAR(bindings); - define(inner_env, CAR(binding), eval(inner_env, op_env, CADR(binding))); - bindings = CDR(bindings); - } - return eval_body(inner_env, op_env, operator, CDR(operands)); -} - - -/* entry_do -- (do (( ) ...) ( ...) ...) */ - -static obj_t entry_do(obj_t env, obj_t op_env, obj_t operator, obj_t operands) -{ - error("%s: unimplemented", operator->operator.name); - return obj_error; -} - - -/* entry_delay -- (delay ) */ - -static obj_t entry_delay(obj_t env, obj_t op_env, obj_t operator, obj_t operands) -{ - obj_t promise; - unless(TYPE(operands) == TYPE_PAIR && - CDR(operands) == obj_empty) - error("%s: illegal syntax", operator->operator.name); - promise = make_pair(obj_false, - make_operator("anonymous promise", - entry_interpret, obj_empty, - CAR(operands), env, op_env)); - TYPE(promise) = TYPE_PROMISE; - return promise; -} - - -/* entry_quasiquote -- (quasiquote