~amirouche/sink-kernel

2778499eb1b23a823542f71d9c8dae20e49e15b5 — Amirouche 1 year, 4 months ago
import code from https://web.cs.wpi.edu/~jshutt/kernel.html
A  => LICENSE +339 -0
@@ 1,339 @@
		    GNU GENERAL PUBLIC LICENSE
		       Version 2, June 1991

 Copyright (C) 1989, 1991 Free Software Foundation, Inc.
                          675 Mass Ave, Cambridge, MA 02139, USA
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

			    Preamble

  The licenses for most software are designed to take away your
freedom to share and change it.  By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users.  This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it.  (Some other Free Software Foundation software is covered by
the GNU Library General Public License instead.)  You can apply it to
your programs, too.

  When we speak of free software, we are referring to freedom, not
price.  Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.

  To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.

  For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have.  You must make sure that they, too, receive or can get the
source code.  And you must show them these terms so they know their
rights.

  We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.

  Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software.  If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.

  Finally, any free program is threatened constantly by software
patents.  We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary.  To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.

  The precise terms and conditions for copying, distribution and
modification follow.

		    GNU GENERAL PUBLIC LICENSE
   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

  0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License.  The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language.  (Hereinafter, translation is included without limitation in
the term "modification".)  Each licensee is addressed as "you".

Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope.  The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.

  1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.

You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.

  2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:

    a) You must cause the modified files to carry prominent notices
    stating that you changed the files and the date of any change.

    b) You must cause any work that you distribute or publish, that in
    whole or in part contains or is derived from the Program or any
    part thereof, to be licensed as a whole at no charge to all third
    parties under the terms of this License.

    c) If the modified program normally reads commands interactively
    when run, you must cause it, when started running for such
    interactive use in the most ordinary way, to print or display an
    announcement including an appropriate copyright notice and a
    notice that there is no warranty (or else, saying that you provide
    a warranty) and that users may redistribute the program under
    these conditions, and telling the user how to view a copy of this
    License.  (Exception: if the Program itself is interactive but
    does not normally print such an announcement, your work based on
    the Program is not required to print an announcement.)

These requirements apply to the modified work as a whole.  If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works.  But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.

Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.

In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.

  3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:

    a) Accompany it with the complete corresponding machine-readable
    source code, which must be distributed under the terms of Sections
    1 and 2 above on a medium customarily used for software interchange; or,

    b) Accompany it with a written offer, valid for at least three
    years, to give any third party, for a charge no more than your
    cost of physically performing source distribution, a complete
    machine-readable copy of the corresponding source code, to be
    distributed under the terms of Sections 1 and 2 above on a medium
    customarily used for software interchange; or,

    c) Accompany it with the information you received as to the offer
    to distribute corresponding source code.  (This alternative is
    allowed only for noncommercial distribution and only if you
    received the program in object code or executable form with such
    an offer, in accord with Subsection b above.)

The source code for a work means the preferred form of the work for
making modifications to it.  For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable.  However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.

If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.

  4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License.  Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.

  5. You are not required to accept this License, since you have not
signed it.  However, nothing else grants you permission to modify or
distribute the Program or its derivative works.  These actions are
prohibited by law if you do not accept this License.  Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.

  6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions.  You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.

  7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all.  For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.

If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.

It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices.  Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.

This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.

  8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded.  In such case, this License incorporates
the limitation as if written in the body of this License.

  9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time.  Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.

Each version is given a distinguishing version number.  If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation.  If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.

  10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission.  For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this.  Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.

			    NO WARRANTY

  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.

  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.

		     END OF TERMS AND CONDITIONS

	Appendix: How to Apply These Terms to Your New Programs

  If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.

  To do so, attach the following notices to the program.  It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.

    <one line to give the program's name and a brief idea of what it does.>
    Copyright (C) 19yy  <name of author>

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

Also add information on how to contact you by electronic and paper mail.

If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:

    Gnomovision version 69, Copyright (C) 19yy name of author
    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
    This is free software, and you are welcome to redistribute it
    under certain conditions; type `show c' for details.

The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License.  Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.

You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary.  Here is a sample; alter the names:

  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
  `Gnomovision' (which makes passes at compilers) written by James Hacker.

  <signature of Ty Coon>, 1 April 1989
  Ty Coon, President of Vice

This General Public License does not permit incorporating your program into
proprietary programs.  If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library.  If this is what you want to do, use the GNU Library General
Public License instead of this License.

A  => copyleft.gnu +339 -0
@@ 1,339 @@
		    GNU GENERAL PUBLIC LICENSE
		       Version 2, June 1991

 Copyright (C) 1989, 1991 Free Software Foundation, Inc.
                          675 Mass Ave, Cambridge, MA 02139, USA
 Everyone is permitted to copy and distribute verbatim copies
 of this license document, but changing it is not allowed.

			    Preamble

  The licenses for most software are designed to take away your
freedom to share and change it.  By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users.  This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it.  (Some other Free Software Foundation software is covered by
the GNU Library General Public License instead.)  You can apply it to
your programs, too.

  When we speak of free software, we are referring to freedom, not
price.  Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.

  To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.

  For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have.  You must make sure that they, too, receive or can get the
source code.  And you must show them these terms so they know their
rights.

  We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.

  Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software.  If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.

  Finally, any free program is threatened constantly by software
patents.  We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary.  To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.

  The precise terms and conditions for copying, distribution and
modification follow.

		    GNU GENERAL PUBLIC LICENSE
   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION

  0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License.  The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language.  (Hereinafter, translation is included without limitation in
the term "modification".)  Each licensee is addressed as "you".

Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope.  The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.

  1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.

You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.

  2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:

    a) You must cause the modified files to carry prominent notices
    stating that you changed the files and the date of any change.

    b) You must cause any work that you distribute or publish, that in
    whole or in part contains or is derived from the Program or any
    part thereof, to be licensed as a whole at no charge to all third
    parties under the terms of this License.

    c) If the modified program normally reads commands interactively
    when run, you must cause it, when started running for such
    interactive use in the most ordinary way, to print or display an
    announcement including an appropriate copyright notice and a
    notice that there is no warranty (or else, saying that you provide
    a warranty) and that users may redistribute the program under
    these conditions, and telling the user how to view a copy of this
    License.  (Exception: if the Program itself is interactive but
    does not normally print such an announcement, your work based on
    the Program is not required to print an announcement.)

These requirements apply to the modified work as a whole.  If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works.  But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.

Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.

In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.

  3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:

    a) Accompany it with the complete corresponding machine-readable
    source code, which must be distributed under the terms of Sections
    1 and 2 above on a medium customarily used for software interchange; or,

    b) Accompany it with a written offer, valid for at least three
    years, to give any third party, for a charge no more than your
    cost of physically performing source distribution, a complete
    machine-readable copy of the corresponding source code, to be
    distributed under the terms of Sections 1 and 2 above on a medium
    customarily used for software interchange; or,

    c) Accompany it with the information you received as to the offer
    to distribute corresponding source code.  (This alternative is
    allowed only for noncommercial distribution and only if you
    received the program in object code or executable form with such
    an offer, in accord with Subsection b above.)

The source code for a work means the preferred form of the work for
making modifications to it.  For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable.  However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.

If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.

  4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License.  Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.

  5. You are not required to accept this License, since you have not
signed it.  However, nothing else grants you permission to modify or
distribute the Program or its derivative works.  These actions are
prohibited by law if you do not accept this License.  Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.

  6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions.  You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.

  7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License.  If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all.  For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.

If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.

It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices.  Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.

This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.

  8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded.  In such case, this License incorporates
the limitation as if written in the body of this License.

  9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time.  Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.

Each version is given a distinguishing version number.  If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation.  If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.

  10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission.  For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this.  Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.

			    NO WARRANTY

  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.

  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.

		     END OF TERMS AND CONDITIONS

	Appendix: How to Apply These Terms to Your New Programs

  If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.

  To do so, attach the following notices to the program.  It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.

    <one line to give the program's name and a brief idea of what it does.>
    Copyright (C) 19yy  <name of author>

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

Also add information on how to contact you by electronic and paper mail.

If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:

    Gnomovision version 69, Copyright (C) 19yy name of author
    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
    This is free software, and you are welcome to redistribute it
    under certain conditions; type `show c' for details.

The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License.  Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.

You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary.  Here is a sample; alter the names:

  Yoyodyne, Inc., hereby disclaims all copyright interest in the program
  `Gnomovision' (which makes passes at compilers) written by James Hacker.

  <signature of Ty Coon>, 1 April 1989
  Ty Coon, President of Vice

This General Public License does not permit incorporating your program into
proprietary programs.  If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library.  If this is what you want to do, use the GNU Library General
Public License instead of this License.

A  => punch +10 -0
@@ 1,10 @@

version 0.2

version 0.3

Test interpreter get-list-metrics (note: input is a kernel-list, not a list).

Systematically test all interpreter procedures.

Ferret out undocumented dependencies between modules.

A  => readme +81 -0
@@ 1,81 @@

These source files collectively form a Scheme program that interprets a
language that is almost, but not quite, Kernel.  The program is called
SINK, which is an acronym for Scheme-based Interpreter for Not-quite Kernel.

The interpreter is meant to have been written in unextended R5RS Scheme.
Incidental file "subfiles/script.scm", which is not part of the interpreter
proper, uses extensions in MzScheme.


Copyright

  This program was designed and written by John N. Shutt, copyright 2009,
  and is distributed under the GNU General Public License version 2 or later.
  Each individual source file begins with a two-line notice:

   ; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
   ; Copyright (c) 2009 John N. Shutt

  This program is free software; you can redistribute it and/or
  modify it under the terms of the GNU Library General Public License
  as published by the Free Software Foundation; either version 2 of
  the License, or (at your option) any later version.

  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU Library General Public License for more details.

  You should have received a copy of the GNU Library General Public
  License along with this program; if not, write to the Free Software
  Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

Platform

  Because the program is written in R5RS Scheme, its Kernel-error-handling
  facilities rely on dynamic-wind to catch errors occurring in native Scheme
  procedures.  Unfortunately, this behavior is not actually spelled out in the
  R5RS, and some implementors of R5RS Scheme have seen fit not to integrate
  dynamic-wind gracefully with their error handling.  Consequently, under some
  implementations of R5RS Scheme an error in a primitive (such as dividing by
  zero) will cause the entire SINK interpreter to abend.  The program was
  developed under MzScheme, where dynamic-wind catches errors as expected (or
  at least it did, as of version 103 of MzScheme that was used during
  development).

Files in the home directory

  readme

    This file.

  rev-log

    A summary of the revision history of the program.

  sink.scm

    The primary source file for running SINK under Scheme interactive mode.
    Loading this file creates the interpreter by loading all secondary source
    files in the proper sequence, and outputs a startup message identifying
    the program and giving instructions on how to run it.

  sink.bat

    An MS-DOS batch file for running SINK directly under the MS-DOS prompt,
    bypassing Scheme interactive mode.

  subfiles/

    Directory containing all the secondary source files.

  test/

    Directory containing miscellaneous (not-quite-)Kernel source files for
    testing.  Source files that are pure Kernel have file type ".krn", those
    that are not (because they use "%" instead of "#") have file type ".snk".

  copyleft.gnu

    The GNU General Public License.

A  => rev-log +30 -0
@@ 1,30 @@
  This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
  Copyright (c) 2009 John N. Shutt

    On program-internal handling of revision numbering,
    see file "subfiles/revision.scm".

revision log

  0.0  2007 August 4   First moderately complete prototype.  Uses a somewhat
                         haphazard mixture of primitive (meta-language) and
                         library (object-language) implementations of derived
                         features.  Only sporadically tested, and some feature
                         implementations consciously do not fully conform to
                         the R-1RK.

  0.1  2007 August 5   Disables most primitive implementations of derived
                         core features, and most library implementations
                         whatsoever, clearing the way for more systematic
                         testing of core derivations from the report.  Some
                         of the disabled primitive implementations are
                         retained in comments (but that needn't imply
                         they're correct).

  0.2                  Adds library implementations of all derived core
                         features.

  0.3                  Replaces primitive implementations of general
                         arithmetic applicatives (+ - * /) with primitive
                         implementations of binary applicatives and library
                         generalizations using reduce.

A  => sink.bat +18 -0
@@ 1,18 @@
@echo off

rem  This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
rem  Copyright (c) 2009 John N. Shutt
rem
rem This is the main file for using SINK from the MS-DOS system prompt,
rem bypassing the Scheme interactive level.  It assumes MzScheme.
rem If there is a system environment variable SINKDIR, it should contain the
rem path to the SINK home directory, and this batch file can then be called
rem from anywhere.  If there is no such variable, this batch file must be
rem called from the SINK home directory.
rem
rem The check for the system environment variable, and changes of current
rem directory, are handled by file "subfiles/script.scm" using features of
rem MzScheme; on other sensitivity of SINK to choice of Scheme implementation,
rem see file "subfiles/operative.scm" procedure naive->action.

mzscheme -r "%SINKDIR%subfiles\\script.scm"

A  => sink.scm +36 -0
@@ 1,36 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

;;;;;;;;;;;;;;;;;;;
; Scheme-based    ;
; Interpreter for ;
; Not-quite       ;
; Kernel          ;
;;;;;;;;;;;;;;;;;;;
;
; This is the main file for using SINK in Scheme interactive mode.
; It constructs SINK and displays instructions on how to run SINK.
; The programmer can then run SINK as many times as desired, and whenever
; SINK terminates the programmer is returned to the Scheme prompt.
;
; Using MzScheme, to load SINK from the SINK home directory, type either
;
;     mzscheme
;     (load "sink.scm")
; or
;     mzscheme -f sink.scm
;
; SINK was developed under MzScheme version 103.  Although the program is
; mostly limited to R5RS Scheme, some details of Kernel error handling won't
; work on some technically R5RS-compliant platforms (on which, see file
; "subfiles/operative.scm" procedure naive->action).
;

(load "subfiles/all.scm")

(display "    Start by calling interpreter with no arguments, thus:")(newline)
(newline)
(display "        (interpreter)")                                    (newline)
(newline)

'SINK-constructed

A  => subfiles/all.scm +51 -0
@@ 1,51 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

;;;;;;;;;;;;;;;;;;;;
; SINK constructor ;
;;;;;;;;;;;;;;;;;;;;
;
; This file constructs SINK, by loading all the other defining files in
; an acceptable order, and displays a short introductory message about SINK.
;
; This file is not meant to be loaded directly by the user; two files are
; provided for that purpose in the SINK program's home directory (the parent of
; the directory where the current file, "all.scm", should reside).  Users who
; want to work from the Scheme interactive level should use file "sink.scm";
; those who want to bypass the Scheme interactive level entirely (and who have
; MzScheme) should use a batch file such as "sink.bat".
;

(load "subfiles/revision.scm")      ; mechanism for tracking revision and date
(load "subfiles/eval.scm")          ; evaluator central logic
(load "subfiles/interpreter.scm")   ; interpreter top level
(load "subfiles/boolean.scm")       ; booleans
(load "subfiles/object.scm")        ; encapsulated objects
(load "subfiles/applicative.scm")   ;   applicatives              (uses object)
(load "subfiles/context.scm")       ;   continuations             (uses object)
(load "subfiles/encapsulation.scm") ;   encapsulation types       (uses object)
(load "subfiles/environment.scm")   ;   environments              (uses object)
(load "subfiles/error.scm")         ;   error descriptors         (uses object)
(load "subfiles/ignore.scm")        ;   ignore                    (uses object)
(load "subfiles/inert.scm")         ;   inert                     (uses object)
(load "subfiles/kernel-pair.scm")   ;   pairs                     (uses object)
(load "subfiles/keyed.scm")         ;   keyed variables           (uses object)
(load "subfiles/number.scm")        ;   number                    (uses object)
(load "subfiles/operative.scm")     ;   operatives                (uses object)
(load "subfiles/port.scm")          ;   ports             (uses dynamic,object)
(load "subfiles/cycles.scm")        ; cyclic structures
(load "subfiles/ground.scm")        ; ground environment (uses everything else)

(newline)
(display "  SINK:  Scheme-based Interpreter for Not-quite Kernel.")   (newline)
(display "  (An interpreter for an approximate subset of Kernel.)")   (newline)
(newline)
(display "  Version ") (display (get-version)) (newline)
(display "  ") (display (get-revision-date)) (display ".") (newline)
(display "  Based on the R-1RK.") (newline)
(newline)
(display "    Use %ignore and %inert for Kernel #ignore and #inert.") (newline)
(display "    Major omissions: ")
(display      " complex numbers; bounds on inexact reals.")           (newline)
(display "    Various standard combiners haven't been defined.")
(newline)

A  => subfiles/applicative.scm +100 -0
@@ 1,100 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 0)
             (list 0.1 0))
(set-revision-date 2007 8 4)

;;;;;;;;;;;;;;;;
; applicatives ;
;;;;;;;;;;;;;;;;
;
; An applicative has type 'applicative, and attribute 'underlying whose value
; is a combiner.
;   The principal constructor is called "wrap" instead of "make-applicative",
; and the accessor is called "unwrap" instead of "get-applicative-underlying".
;

(define wrap
  (lambda (combiner)
    (let ((appv  (let ((name  (list #t)))
                   (lambda (message)
                     (case message
                       ((type)       'applicative)
                       ((name)       name)
                       ((underlying) combiner))))))
      (designate-name-inheritor! appv combiner)
      appv)))

(define applicative? (make-object-type-predicate 'applicative))

(define unwrap (lambda (x) (x 'underlying)))

;
;
;
(define unary-predicate->applicative
  (lambda x
    (wrap (apply unary-predicate->operative x))))

(define binary-predicate->applicative
  (lambda x
    (wrap (apply binary-predicate->operative x))))

(define metered-action->checked-applicative
  (lambda x
    (wrap (apply metered-action->checked-operative x))))

(define naive->checked-applicative
  (lambda x
    (wrap (apply naive->checked-operative x))))

(define metered-naive->checked-applicative
  (lambda x
    (wrap (apply metered-naive->checked-operative x))))

;
; Given an action, and criteria for admissible argument-lists for that action,
; constructs an applicative that checks its argument-list for those criteria,
; and either invokes the given action, or throws an error.  Shorthand for
; composition of wrap with action->checked-operative.
;
(define action->checked-applicative
  (lambda x
    (wrap (apply action->checked-operative x))))

;
; Given an action, constructs an applicative whose underlying operative has
; that action.  Shorthand for composition of wrap with action->operative.
;
(define action->applicative
  (lambda (action)
    (wrap (action->operative action))))

;
; Creates bindings for this type in a given environment.
;
; This code should not use any internal knowledge of the applicative type.
; It appears in this file, rather than in "subfiles/ground.scm", simply
; because it is logically associated with the applicative type.
;
(define bind-applicative-primitives!
  (lambda (env)
    (add-bindings! env

      'applicative?
      (unary-predicate->applicative  applicative?)

      'wrap
      (action->checked-applicative
        (lambda (operand-tree env context)
          (wrap (kernel-car operand-tree)))
        1  1 combiner?)

      'unwrap
      (action->checked-applicative
        (lambda (operand-tree env context)
          (unwrap (kernel-car operand-tree)))
        1  1 applicative?)

      )))

A  => subfiles/boolean.scm +52 -0
@@ 1,52 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 0)
             (list 0.1 0))
(set-revision-date 2007 8 5)

;;;;;;;;;;;;
; booleans ;
;;;;;;;;;;;;

;
; Given zero or more boolean arguments, returns their conjunction (i.e.,
; returns #t unless at least one of them is false).
;
(define and?
  (lambda ls
    (or (null? ls)
        (and (car ls)
             (apply and? (cdr ls))))))

;
; Creates bindings for handling booleans in a given environment.
;
(define bind-boolean-primitives!
  (lambda (env)
    (add-bindings! env

      'boolean?
      (unary-predicate->applicative boolean?)

    ; 'and?
    ; (action->checked-applicative
    ;   (lambda (operand-tree env context)
    ;     (apply and? (kernel-list->list operand-tree)))
    ;   0 -1 boolean?)

      '$if
      (action->checked-operative
        (lambda (operand-tree env context)
          (let ((test  (eval (kernel-car operand-tree) env context)))
            (if (boolean? test)
                (if test
                    (eval (kernel-cadr operand-tree) env context)
                    (eval (kernel-caddr operand-tree) env context))
                (error-pass
                  (make-error-descriptor
                    "Non-boolean test result, when calling #[operative $if]")
                  context))))
          3 3)

      )))

A  => subfiles/context.scm +432 -0
@@ 1,432 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 1)
             (list 0.1 1))
(set-revision-date 2009 9 7)

;;;;;;;;;;;;
; contexts ;
;;;;;;;;;;;;
;
; The name "context" is used within the interpreter for what the Kernel
; programmer calls a "continuation".  The word "continuation" is used for
; Scheme continuations.
;
; A context has type 'continuation (because that's the name that should be
; visible within Kernel), and attributes 'receiver, 'parent, 'entry-guards,
; 'exit-guards, 'error-context, 'terminal-context, 'alist, and 'mark.  None
; of the attributes is directly accessible to clients.
;
;   'receiver is a continuation.  When an abnormal pass arrives at its
; destination, the abnormally passed value goes to the destination's receiver.
;
;   'parent is either nil or a context.  The parent (even if nil) contains
; this context, or equivalently, is an ancestor of this context.  Ancestry
; and containment are improper unless otherwise stated, i.e., a context is
; an ancestor of/contains itself.
;
;   'entry-guards and 'exit-guards are each a list of context/procedure pairs.
; Each pair is called a "guard", its context a "selector", and its procedure
; an "interceptor".
;   When an abnormal pass is scheduled, a list is made of interceptors to be
; called along the way.  At most one exit interceptor is selected from each
; context to be exited, in the order they will be exited, and then at most one
; entry interceptor from each context to be entered, in the order they will be
; entered.  For each exited context, the first exit guard is selected whose
; selector contains the destination of the abnormal pass; for each entered
; context, the first entry guard is selected whose selector contains the source
; of the abnormal pass.
;   Once the interceptors for the abnormal pass have been selected, they are
; used in series to transform the abnormally passed value; i.e., the value is
; passed as an argument to the first interceptor, the output of the first is
; passed as an argument to the second, etc.  The output of the last interceptor
; goes to the destination's receiver.
;
;   'error-context is a context.  When an error occurs, a descriptor of the
; error is abnormally passed to the error-context.
;
;   'terminal-context is a context.  Abnormally passing any value to the
; terminal-context requests termination of the interpreter.
;
;   'alist is a list of keyed-bindings, constructed by tools in file
; "subfiles/keyed.scm".
; 
;   'mark is a pair, unique to this context, whose car is a boolean.  Its
; car is #f except during ancestry-determination algorithms.  A context
; whose mark's car is #t is said to be "marked".  Marking contexts allows
; ancestry-determination algorithms to run in linear rather than quadratic
; time.
;

(define make-context
  (lambda (receiver parent entry-guards exit-guards
                    error-context terminal-context alist)
    (let ((name  (list #t))
          (mark  (list #f)))
      (lambda (message)
        (case message
          ((type)             'continuation)
          ((name)             name)
          ((receiver)         receiver)
          ((parent)           parent)
          ((entry-guards)     entry-guards)
          ((exit-guards)      exit-guards)
          ((mark)             mark)
          ((error-context)    error-context)
          ((terminal-context) terminal-context)
          ((alist)            alist))))))

(define context? (make-object-type-predicate 'continuation))

;
; A call to make-top-level-context may return multiple times.  The first time,
; it returns a newly allocated top-level context.  On later returns from the
; same call, it returns the same top-level context again, as long as processing
; should continue; if it returns nil, processing should terminate.
;
;   The top-level context's receiver returns the top-level context from the
; make-top-level-context call.
;
;   The top-level context's error-context's receiver passes its received
; value to the error-handling procedure (provided as an argument to
; make-top-level-context), and calls the top-level context's receiver.
;
;   The top-level context's terminal-context's receiver returns nil from the
; make-top-level-context call.
;
;   The top-level context's alist is provided by
; make-top-level-dynamic-alist.
;    
(define make-top-level-context
  (lambda (error-handler)
    (call-with-current-continuation
      (lambda (c)
        (letrec ((receiver
                   (lambda ignore (c normal-context)))
                 (alist
                   (make-top-level-dynamic-alist))
                 (terminal-context
                   (let ((delegate  (make-context
                                      (lambda ignore (c ()))
                                      () () () () () alist)))
                     (lambda (message)
                       (case message
                         ((error-context)     error-context)
                         ((terminal-context)  terminal-context)
                         (else                (delegate message))))))
                 (error-context
                   (let ((delegate  (make-context
                                      (lambda (ed)
                                        (receiver (error-handler ed)))
                                      () () () () () alist)))
                     (lambda (message)
                       (case message
                         ((parent)            terminal-context)
                         ((error-context)     error-context)
                         ((terminal-context)  terminal-context)
                         (else                (delegate message))))))
                 (normal-context
                   (let ((delegate  (make-context
                                      receiver
                                      () () () () () alist)))
                     (lambda (message)
                       (case message
                         ((parent)            terminal-context)
                         ((error-context)     error-context)
                         ((terminal-context)  terminal-context)
                         (else                (delegate message)))))))
          (receiver))))))

;
; call-with-guarded-context takes as arguments a procedure, parent context, and
; entry and exit guards; and passes as the single argument to the procedure
; a new context whose receiver is the return continuation from the call to
; call-with-guarded-context, whose parent and guards are as specified, and
; whose error-context terminal-context and alist are inherited from the parent.
;

(define call-with-guarded-context
  (lambda (proc parent entry-guards exit-guards)
    (call-with-current-continuation
      (lambda (receiver)
        (let ((error-context     (parent 'error-context))
              (terminal-context  (parent 'terminal-context))
              (alist             (parent 'alist)))
          (proc (make-context receiver parent entry-guards exit-guards
                              error-context terminal-context alist)))))))

;
; call-with-keyed-context takes as arguments a procedure, parent context, and
; key and value for a keyed binding; and passes as the single argument to
; the procedure a new context whose receiver is the return continuation from
; the call to call-with-keyed-context, whose parent is as specified, whose
; guard lists are empty, whose error-context and terminal-context are inherited
; from the parent, and whose alist is inherited from the parent except for the
; given keyed binding.
;

(define call-with-keyed-context
  (lambda (proc parent key value)
    (call-with-current-continuation
      (lambda (receiver)
        (let ((error-context     (parent 'error-context))
              (terminal-context  (parent 'terminal-context))
              (alist             (make-alist (parent 'alist) key value)))
          (proc (make-context receiver parent () ()
                              error-context terminal-context alist)))))))

;
; Given the internal key for a keyed variable, and a context, looks up the
; value of that keyed variable in that context's alist.  Returns the value
; if found, or signals an error.
;

(define context-keyed-lookup
  (lambda (key context)
    (let ((binding  (alist-lookup key (context 'alist))))
      (if (pair? binding)
          (cdr binding)
          (error-pass
            (make-error-descriptor
              "Attempted to look up an unbound keyed dynamic variable"
              (list "in " (list context)))
            context)))))

;
; Given an environment and a context, binds symbols root-continuation and
; error-continuation in the given environment to the terminal-context and
; error-context of the given context.
;
(define initialize-context-bindings
  (lambda (env context)
    (add-bindings! env 'root-continuation (context 'terminal-context)
                       'error-continuation (context 'error-context))))

;
; Given a context, constructs an applicative that abnormally passes its
; argument tree to that context.
;
(define context->applicative
  (lambda (dest-context)
    (let ((this
            (action->applicative
              (lambda (operand-tree env source-context)
                (abnormally-pass operand-tree source-context dest-context)))))
      (designate-name-inheritor! (unwrap this) dest-context)
      this)))

;
; Given an error descriptor and the context in which the error occurred,
; abnormally passes the error descriptor to an appropriate error-handling
; context.
;
(define error-pass
  (lambda (descriptor source)
    (abnormally-pass descriptor source (source 'error-context))))

;
; Given a value and the context in which interpreter termination is requested,
; abnormally passes the value to that context's terminal-context.
;
(define terminal-pass
  (lambda (descriptor source)
    (abnormally-pass descriptor source (source 'terminal-context))))

;
; Abnormally passes a value from within a source context to a destination
; context.
;
(define abnormally-pass
  (letrec (;
           ; Given a context and a boolean, stores the boolean in the cars of
           ; the marks of all the ancestors of the context.
           ;
           (set-marks!
             (lambda (context boolean)
               (if (not (null? context))
                   (begin
                     (set-car! (context 'mark) boolean)
                     (set-marks! (context 'parent) boolean)))))
           ;
           ; Given a list of guards and a list of previously selected
           ; interceptors, and assuming that all ancestors of a target context
           ; are marked, selects at most one interceptor whose selector
           ; contains the target and prepends it to the list.  Returns the
           ; updated list of selected interceptors.
           ;
           (select-at-most-one
             (lambda (guards previously-selected)
               (cond ((null? guards)
                        previously-selected)
                     ((or (null? (caar guards))
                          (car ((caar guards) 'mark)))
                        (cons (cdar guards)
                              previously-selected))
                     (else (select-at-most-one (cdr guards)
                                               previously-selected)))))
           ;
           ; Given a context that contains the destination, and a list of
           ; selected entry-interceptors strictly below the given context, and
           ; assuming that all ancestors of the source are marked, returns a
           ; list of all selected entry-interceptors for the abnormal pass.
           ;
           (select-entry-interceptors
             (lambda (context previously-selected)
               (if (or (null? context)
                       (car (context 'mark)))
                   previously-selected
                   (select-entry-interceptors
                     (context 'parent)
                     (select-at-most-one
                       (context 'entry-guards)
                       previously-selected)))))
           ;
           ; Given a context that contains the source, and a list of all
           ; selected entry-interceptors for the abnormal pass, and assuming
           ; that all ancestors of the destination are marked, returns a list
           ; of selected interceptors including exit-interceptors at or above
           ; the given context.
           ;
           (select-exit-interceptors
             (lambda (context previously-selected)
               (if (or (null? context)
                       (car (context 'mark)))
                   previously-selected
                   (select-at-most-one
                     (context 'exit-guards)
                     (select-exit-interceptors
                       (context 'parent)
                       previously-selected)))))
           ;
           ; Given a list of interceptors and an abnormally passed value, uses
           ; the interceptors in series to transform the value; i.e., the value
           ; is passed as an argument to the first interceptor, the output of
           ; the first is passed as an argument to the second, etc.
           ;
           (serial-transform
             (lambda (interceptors value)
               (if (null? interceptors)
                   value
                   (serial-transform (cdr interceptors)
                                     ((car interceptors) value))))))

    (lambda (value source destination)
      (set-marks! source #t)
      (let ((selected  (select-entry-interceptors destination ())))
        (set-marks! source #f)
        (set-marks! destination #t)
        (let ((selected  (select-exit-interceptors source selected)))
          (set-marks! destination #f)
          ((destination 'receiver) (serial-transform selected value)))))))

;
; Creates bindings for this type in a given environment.
;
; This code should not use any internal knowledge of the context type.
; It appears in this file, rather than in "subfiles/ground.scm", simply
; because it is logically associated with the context type.
;
(define bind-context-primitives!
  (lambda (env)

    (define guards-list?
      (lambda (x)
        (and (kernel-list? x)
             (apply and?
                    (map (lambda (x)
                           (and (kernel-pair? x)
                                (context? (kernel-car x))
                                (kernel-pair? (kernel-cdr x))
                                (applicative? (kernel-cadr x))
                                (operative? (unwrap (kernel-cadr x)))
                                (null? (kernel-cddr x))))
                         (kernel-list->list x))))))

    (add-bindings! env

      'continuation?
      (unary-predicate->applicative  context?)

      'call/cc
      (action->checked-applicative
        (lambda (operand-tree env context)
          (call-with-guarded-context
            (lambda (context)
              (eval (kernel-list (kernel-car operand-tree) context)
                    env context))
            context
            ()
            ()))
        1 1 combiner?)

      'extend-continuation
      (action->checked-applicative
        (lambda (operand-tree env context)
          (let ((parent  (kernel-car  operand-tree))
                (appv    (kernel-cadr operand-tree))
                (env     (if (kernel-pair? (kernel-cddr operand-tree))
                             (kernel-caddr operand-tree)
                             (make-environment))))
            (call-with-current-continuation
              (lambda (c)
                (let ((operand-tree
                        (call-with-current-continuation
                          (lambda (receiver)
                            (let ((error-context    (parent 'error-context))
                                  (terminal-context (parent 'terminal-context))
                                  (alist            (parent 'alist)))
                              (c (make-context receiver parent () ()
                                   error-context terminal-context alist)))))))
                  ((parent 'receiver)
                   (eval (kernel-cons (unwrap appv) operand-tree)
                         env parent)))))))
        2 3 context? applicative? environment?)

      'guard-continuation
      (action->checked-applicative
        (lambda (operand-tree env context)
          (let* ((divert  ())
                 (convert-clause
                   (lambda (clause)
                     (let ((selector     (kernel-car clause))
                           (interceptor  (unwrap (kernel-cadr clause))))
                       (cons selector
                             (lambda (x)
                               (eval (kernel-list
                                       interceptor
                                       x (context->applicative divert))
                                     env divert))))))
                 (entry-guards  (map convert-clause
                                     (kernel-list->list
                                       (kernel-car operand-tree))))
                 (parent        (kernel-cadr operand-tree))
                 (exit-guards   (map convert-clause
                                     (kernel-list->list
                                       (kernel-caddr operand-tree)))))
             (call-with-current-continuation
               (lambda (c)
                 (let ((operand-tree
                         (call-with-guarded-context
                           (lambda (outer-context)
                             (call-with-guarded-context
                               (lambda (inner-context)
                                 (set! divert outer-context)
                                 (c inner-context))
                               outer-context
                               ()
                               exit-guards))
                           parent
                           entry-guards
                           ())))
                   ((parent 'receiver)
                    operand-tree))))))
        3 3 guards-list? context? guards-list?)

      'continuation->applicative
      (action->checked-applicative
        (lambda (operand-tree env context)
          (context->applicative (kernel-car operand-tree)))
        1 1 context?)

      )))

A  => subfiles/cycles.scm +587 -0
@@ 1,587 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.1 0))
(set-revision-date 2007 8 5)

;;;;;;;;;;;;;;;;;;;;;
; cyclic structures ;
;;;;;;;;;;;;;;;;;;;;;
;
; Kernel treats cyclic structures of kernel-pairs (such as cyclic lists) as
; first-class objects, by guaranteeing that each standard combiner will handle
; cyclic structures in finite time whenever that behavior is consistent with
; the intended semantics of the combiner.
;
; The tools in this file help SINK to handle cyclic structures.  However,
; despite the availability of these tools, at last check SINK did not (yet)
; handle cyclic structures in all cases required by Kernel.
;
; The tools here do not use any internal knowledge of the kernel-pair type.
; Cycle-related tools that do use internal knowledge of that type are in file
; "subfiles/kernel-pair.scm".
;
; A kernel-tree is called simply a "tree", because the interpreter has no
; occasion to use Scheme trees.  A kernel-pair may be visited more than once
; during normal (left-to-right, depth first) traversal of a tree without
; constituting a cycle, so long as the revisited kernel-pair isn't a
; descendant of itself.
;
; Even if all kernel-pairs were known to be represented by pairs (which, if it
; were true, should only be known in "subfiles/kernel-pair.scm"), it would be
; necessary to handle them with tongs in Scheme, because Scheme doesn't grant
; first-class status to cyclic pair-structures.  Notably, the argument list of
; a procedure cannot be cyclic.  In Kernel, of course, there is no difficulty
; in using a cyclic argument list (or operand list).
;

;
; Given improper kernel-list ls and nonnegative integer k, returns the (k)th
; kernel-cdr of ls.  Thus, if k=0, returns ls.
;
(define kernel-list-tail
  (lambda (ls k)
    (if (> k 0)
        (kernel-list-tail (kernel-cdr ls) (- k 1))
        ls)))

;
; Given improper kernel-list ls and nonnegative integer k, returns the
; kernel-car of the (k)th kernel-cdr of ls.  Thus, if k=0, returns the
; kernel-car of ls; if k=1, returns the kernel-cadr of ls; and so on.
;
(define kernel-list-ref
  (lambda (ls k)
    (kernel-car (kernel-list-tail ls k))))

;
; Given a value to be construed as an improper kernel-list, returns a list
; of the following four statistics about the value:
;
;   p = the number of kernel-pairs in the improper list.
;   n = the number of nils in the improper list
;         (1 if proper and finite, else 0).
;   a = the number of kernel-pairs in the acyclic prefix of the improper list.
;   c = the number of kernel-pairs in the cycle of the improper list
;         (0 if not a cyclic list).
;
; The algorithm here is linear-time, requiring two passes through the improper
; list, of which the first pass may traverse the improper list for up to twice
; its length, and the second pass traverses it for its length.
;  (1) In the first pass, aux, we determine either that the list is acyclic,
; or the length of its cycle; to detect a cycle, each kernel-pair at position n
; in the list is compared for eq?-ness to the kernel-pair at the most recent
; power-of-two index.  Each kernel-pair is compared to only one other, and we
; can't overshoot the beginning of the cycle by more than a factor of two, so
; this pass takes time linear in the number of kernel-pairs.  If there's no
; cycle, we're done.
;  (2) A second pass, aux2, determines where the cycle begins, by comparing
; each kernel-pair starting from the beginning of the list to the kernel-pair
; displaced to its right by exactly the cycle length (which we know, from the
; first pass).
;
; An alternative algorithm would be to use encapsulated integer marks on
; kernel-pairs; one would then require two passes of just the length of the
; improper list.  That algorithm would have to be in file
; "subfiles/kernel-pair.scm", since it would use private information about
; kernel-pair.  However, even if one did that, it would save less than fifty
; percent in traversal length, and the traversal steps could be significantly
; more expensive since they would involve modifying the encapsulated mark
; fields.  That's not even getting in to questions of reentrance and
; parallelization.
;
(define get-list-metrics
  (lambda (x)

    ; find the cycle length
    (define aux
      (lambda (current-x ; the item we're going to look at now
               current-n ; the number of kernel-pairs we've already passed
               old-x     ; an earlier kernel-pair to compare with this item
               old-n     ; the number of kernel-pairs preceding old-x
               next-n)   ; when to replace old-x
        (cond ((not (kernel-pair? current-x))
                 (list current-n (if (null? current-x) 1 0)
                       current-n 0))
              ((eq? current-x old-x)
                 (aux2 (- current-n old-n)))
              ((< current-n next-n)
                 (aux (kernel-cdr current-x) (+ 1 current-n)
                      old-x                  old-n
                                             next-n))
              (else
                 (aux (kernel-cdr current-x) (+ 1 current-n)
                      current-x              current-n
                                             (* 2 current-n))))))

    ; find the acyclic prefix length
    (define aux2
      (lambda (cycle-length)
        (let ((acyclic-prefix-length
                (aux3 x (kernel-list-tail x cycle-length) 0)))
          (list (+ acyclic-prefix-length cycle-length)
                0
                acyclic-prefix-length
                cycle-length))))

    ; find the acyclic prefix length
    (define aux3
      (lambda (x y n)
        (if (eq? x y)
            n
            (aux3 (kernel-cdr x) (kernel-cdr y) (+ 1 n)))))

    (if (kernel-pair? x)
        (aux (kernel-cdr x) 1 x 0 8)
        (list 0 (if (null? x) 1 0) 0 0))))

;
; Given a value, determines whether that value is a list in the Kernel sense,
; i.e., either a finite list terminated by nil, or a cyclic list.
;
(define kernel-list?
  (lambda (ls)
    (let* ((metrics  (get-list-metrics ls))
           (n  (cadr metrics))
           (c  (cadddr metrics)))
      (or (> n 0)
          (> c 0)))))

;
; Given a value, determines whether that value is a finite list.
;
(define finite-list?
  (lambda (ls)
    (> (cadr (get-list-metrics ls)) 0)))

;
; Given a value, determines whether that value is a cyclic list.
;
(define cyclic-list?
  (lambda (ls)
    (> (cadddr (get-list-metrics ls)) 0)))

;
; Given a cons-like procedure some-cons, returns a procedure that,
; given integer n-pairs, procedure proc, and kernel-list ls, where the length
; of ls is at least n-pairs, calls proc on each of the first n-pairs elements
; of ls, and returns a finite some-list of the results.
;
; This higher-order procedure captures the common structure of
; bounded-simple-map, which returns a finite mutable kernel-list, and
; bounded-simple-map->list, which returns a list.
;
(define make-bounded-simple-map
  (lambda (some-cons)
    (letrec ((mapper  (lambda (n-pairs proc ls)
                        (if (> n-pairs 0)
                            (some-cons (proc (kernel-car ls))
                                       (mapper (- n-pairs 1)
                                               proc
                                               (kernel-cdr ls)))
                            ()))))
      mapper)))

(define bounded-simple-map       (make-bounded-simple-map kernel-cons))
(define bounded-simple-map->list (make-bounded-simple-map cons))

;
; Given a kernel-list, returns a freshly allocated list with the same elements
; in the same order.
;
; If the resultant list certainly won't be mutated, use  kernel-list->list.
;
(define copy-kernel-list->list
  (lambda (ls)
    (bounded-simple-map->list (car (get-list-metrics ls))
                              (lambda (x) x)
                              ls)))

;
; Given mutable kernel-list ls, nonnegative integer a, and nonnegative integer
; c, where the number of kernel-pairs in ls is at least a+c, if c is zero does
; nothing, otherwise sets the kernel-cdr of the (a+c)th kernel-pair of ls to
; point to the (a+1)th kernel-pair of ls.  After mutation, ls has acyclic
; prefix length a and cycle length c.
;
(define kernel-encycle!
  (lambda (ls a c)
    (if (> c 0)
        (kernel-set-cdr! (kernel-list-tail ls (+ a c -1))
                         (kernel-list-tail ls a)))))

;
; Given procedure proc and kernel-list ls, calls proc on each element of ls
; (just once for each eq?-distinct position in ls), and returns
; a mutable kernel-list of the results structurally isomorphic to ls.
;
; For example, using curly braces for a kernel-list,
;
;       (simple-map (lambda (x) (+ x 5)) {1 2 #0={3 4 . #0#}})
;   ==>
;       {6 7 #0={8 9 . #0#}}
;
(define simple-map
  (lambda (proc ls)
    (let* ((metrics  (get-list-metrics ls))
           (p  (car metrics))
           (a  (caddr metrics))
           (c  (cadddr metrics)))
      (if (<= p 0)
          ()
          (let ((ls  (bounded-simple-map p proc ls)))
            (kernel-encycle! ls a c)
            ls)))))

;
; Given a nonempty kernel-list of kernel-lists lss, constructs a
; finite mutable kernel-list whose n^th element is a mutable kernel-list of
; the n^th elements of the kernel-lists in lss; each element of the resultant
; kernel-list has the topological structure of lss, and the length of the
; resultant kernel-list is just large enough to include every combination of
; elements from the kernel-lists in lss.  The result returned is a list whose
; first element is the resultant kernel-list, and whose second and third
; elements are the acyclic prefix length and cycle length that would encycle
; the resultant kernel-list to be traversal-isomorphic to the infinite
; transpose of lss.  If the kernel-lists in lss don't all have the same
; length, an error-message string is returned.
;
;       (transpose-lists '{{1 2 3} {4 5 6}})
;   ==>
;       ({{1 4} {2 5} {3 6}} 3 0)
;
;       (transpose-lists '#0={{1 #1={2 3 . #1#}} {4 5 #2={6 . #2#}} . #0#})
;   ==>
;       ({#0={1 4 . #0#} #1={2 5 . #1#} #2={3 6 . #2#} #3={2 6 . #3#}} 2 2)
;
(define transpose-lists
  (lambda (lss)

    (define get-results-metrics
      (lambda (so-far remaining)
        (if (null? remaining)
            so-far
            (let ((next       (car remaining))
                  (remaining  (cdr remaining)))
              (let ((sa  (caddr so-far))
                    (sc  (cadddr so-far))
                    (na  (caddr next))
                    (nc  (cadddr next)))
                (if (or (not (eq? (zero? sc) (zero? nc)))
                        (and (zero? sc) (zero? nc) (not (= sa na))))
                    "lists don't have the same length"
                    (let ((a  (max sa na))
                          (c  (if (zero? sc) sc (lcm sc nc))))
                      (get-results-metrics (list (+ a c) (cadr so-far) a c)
                                           remaining))))))))

    (define aux
      (lambda (k lss p a c)
        (if (<= k 0)
            ()
            (let ((x  (bounded-simple-map p kernel-car lss))
                  (y  (bounded-simple-map p kernel-cdr lss)))
              (kernel-encycle! x a c)
              (kernel-cons x (aux (- k 1) y p a c))))))

    (let* ((lss-metrics  (get-list-metrics lss))
           (lss-p        (car lss-metrics))
           (lss-a        (caddr lss-metrics))
           (lss-c        (cadddr lss-metrics)))
      (let* ((metrics-list  (bounded-simple-map->list
                              lss-p get-list-metrics lss))
             (results-metrics  (get-results-metrics (car metrics-list)
                                                    (cdr metrics-list))))
        (if (string? results-metrics)
            results-metrics
            (let ((rp  (car results-metrics))
                  (ra  (caddr results-metrics))
                  (rc  (cadddr results-metrics)))
              (list (aux rp lss lss-p lss-a lss-c)
                    ra rc)))))))

;
; Given procedure proc and nonempty kernel-list of kernel-lists lss,
; repeatedly calls proc with a single mutable kernel-list argument constructed
; by taking the n^th elements of each kernel-list in lss, for n from 1 to a
; large enough number to cover every combination of positions in the different
; kernel-lists.  Each argument has the topological structure of lss.  Returns
; a mutable kernel-list of the results of the calls to proc, with appropriate
; topological structure.  If the kernel-lists in lss have different lengths,
; the operation cannot be performed correctly, so an error-message string is
; returned instead.
;
;       (full-map (lambda (x) (apply + x)) '{{1 2 3} {4 5 6}})
;   ==>
;       {5 7 9}
;
;       (full-map (lambda (x) (apply + x))
;                 '{{1 #0={2 3 . #0#}} {4 5 #1={6 7 8 . #1#}}})
;   ==>
;       {5 7 #0={9 9 11 8 10 10 . #0#}}
;
(define full-map
  (lambda (proc lss)
    (let ((x  (transpose-lists lss)))
      (if (string? x)
          x
          (let ((ls  (car x))
                (a   (cadr x))
                (c   (caddr x)))
            (let ((ls  (bounded-simple-map (+ a c) proc ls)))
              (kernel-encycle! ls a c)
              ls))))))

;
; Given two structures x and y, either of which may be cyclic, determine
; whether they are equal?.
;
; A table is maintained to keep track of which constituents (kernel-pairs) of
; x do not have to be compared again to which constituents of y.  The table
; is a list; each element of this list is a pair, whose first element is a
; constituent of x, and whose subsequent elements are constituents of y that
; don't have to be recompared to it.
;
; There is no call for this tool to use encapsulated knowledge about the
; kernel-pair type, because marking individual kernel-pairs wouldn't help.
;
(define kernel-equal?
  (lambda (x y)

    (define table ())

    (define get-row
      (lambda (x)
        (let ((row  (assq x table)))
          (if (pair? row)
              row
              (let ((row  (list x)))
                (set! table (cons row table))
                row)))))

    (define is-in-row?
      (lambda (y row)
        (if (pair? (memq y row))
            #t
            (begin
              (set-cdr! row (cons y (cdr row)))
              #f))))

    (define aux
      (lambda (x y)
        (cond ((and (kernel-pair? x) (kernel-pair? y))
                 (if (is-in-row? y (get-row x))
                     #t
                     (and (aux (kernel-car x) (kernel-car y))
                          (aux (kernel-cdr x) (kernel-cdr y)))))
              ((and (kernel-number? x) (kernel-number? y))
                 (kernel-=? x y))
              ((and (string? x) (string? y))
                 (string=? x y))
              (else
                 (eq? x y)))))

    (aux x y)))

;
; Creates bindings for handling cyclic structures in a given environment.
;
(define bind-cyclic-primitives!
  (lambda (env)
    (add-bindings! env

    ; 'get-list-metrics
    ; (action->checked-applicative
    ;   (lambda (operand-tree env context)
    ;     (list->kernel-list (get-list-metrics (kernel-car operand-tree))))
    ;   1 1)

    ; 'finite-list?
    ; (unary-predicate->applicative finite-list?)

    ; 'countable-list?
    ; (unary-predicate->applicative kernel-list?)

    ; 'member?
    ; (action->checked-applicative
    ;   (lambda (operand-tree env context)
    ;     (let* ((object (kernel-car operand-tree))
    ;            (ls     (kernel-cadr operand-tree))
    ;            (p      (car (get-list-metrics ls))))
    ;       (letrec ((aux?  (lambda (k ls)
    ;                         (if (<= k 0)
    ;                             #f
    ;                             (or (kernel-equal? object (kernel-car ls))
    ;                                 (aux? (- k 1) (kernel-cdr ls)))))))
    ;         (aux? p ls))))
    ;   2 2 any? kernel-list?)

    ; 'memq?
    ; (action->checked-applicative
    ;   (lambda (operand-tree env context)
    ;     (let* ((object (kernel-car operand-tree))
    ;            (ls     (kernel-cadr operand-tree))
    ;            (p      (car (get-list-metrics ls))))
    ;       (letrec ((aux?  (lambda (k ls)
    ;                         (if (<= k 0)
    ;                             #f
    ;                             (or (eq? object (kernel-car ls))
    ;                                 (aux? (- k 1) (kernel-cdr ls)))))))
    ;         (aux? p ls))))
    ;   2 2 any? kernel-list?)

    ; 'list-tail
    ; (action->checked-applicative
    ;   (lambda (operand-tree env context)
    ;     (let* ((ls  (kernel-car operand-tree))
    ;            (k   (kernel-cadr operand-tree))
    ;            (p   (car (get-list-metrics ls))))
    ;       (if (< p k)
    ;           (error-pass (make-error-descriptor
    ;                         (list "List isn't long enough"
    ;                               " when calling #[operative list-tail]")
    ;                         (list "Operand tree: " (list operand-tree)))
    ;                       context)
    ;           (kernel-list-tail ls k))))
    ;   2 2 kernel-list? integer?)

    ; 'list-ref
    ; (action->checked-applicative
    ;   (lambda (operand-tree env context)
    ;     (let* ((ls  (kernel-car operand-tree))
    ;            (k   (kernel-cadr operand-tree))
    ;            (p   (car (get-list-metrics ls))))
    ;       (if (<= p k)
    ;           (error-pass (make-error-descriptor
    ;                         (list "List isn't long enough"
    ;                               " when calling #[operative list-ref]")
    ;                         (list "Operand tree: " (list operand-tree)))
    ;                       context)
    ;           (kernel-list-ref ls k))))
    ;   2 2 kernel-list? integer?)

    ; 'encycle!
    ; (action->checked-applicative
    ;   (lambda (operand-tree env context)
    ;     (let* ((ls  (kernel-car operand-tree))
    ;            (a   (kernel-cadr operand-tree))
    ;            (c   (kernel-caddr operand-tree))
    ;            (p   (car (get-list-metrics ls))))
    ;       (cond ((< c 1)  ())
    ;             ((< p (+ a c))
    ;                (error-pass (make-error-descriptor
    ;                              (list "List isn't long enough"
    ;                                    " when calling #[operative encycle!]")
    ;                              (list "Operand tree: " (list operand-tree)))
    ;                            context))
    ;             ((immutable? (kernel-list-tail ls (+ a c -1)))
    ;                (error-pass (make-error-descriptor
    ;                              (list "Target is immutable"
    ;                                    " when calling #[operative encycle!]")
    ;                              (list "Operand tree: " (list operand-tree)))
    ;                            context))
    ;             (else  (kernel-encycle! ls a c))))
    ;     inert)
    ;   3 3 any? integer? integer?)

    ; 'map
    ; (action->checked-applicative
    ;   (lambda (operand-tree env context)
    ;     (let ((combiner  (unwrap (kernel-car operand-tree)))
    ;           (lss       (kernel-cdr operand-tree)))
    ;       (let ((result  (full-map (lambda (args)
    ;                                  (eval (kernel-cons combiner args)
    ;                                        env context))
    ;                                lss)))
    ;         (if (string? result)
    ;             (error-pass
    ;               (make-error-descriptor
    ;                 (list result ", when calling #[operative map]"))
    ;               context)
    ;             result))))
    ;   2 -1 applicative? kernel-list?)

    ;;;;;;;;;;;; doesn't look right
    ; 'append
    ; (action->checked-applicative
    ;   (lambda (operand-tree env context)
    ;
    ;     (define mutable-finite-list?
    ;       (lambda (ls)
    ;         (let* ((metrics  (get-list-metrics ls))
    ;                (p        (car metrics))
    ;                (c        (cadddr metrics)))
    ;           (and (zero? c)
    ;                (or (zero? p)
    ;                    (mutable? (kernel-list-tail ls (- p 1))))))))
    ;
    ;     (define check-operands
    ;       (lambda (n k operands)
    ;         (if (>= n k)
    ;             (if (mutable-finite-list? (kernel-car operands))
    ;                 (check-operands n (+ k 1) (kernel-cdr operands))
    ;                 (error-pass
    ;                   (make-error-descriptor
    ;                     (string-append "Operand #" (number->string k)
    ;                       (if (finite-list? (kernel-car operands))
    ;                           " is immutable"
    ;                           " has wrong type")
    ;                       " when calling #[operative append]")
    ;                     (list "Operand tree: " (list operand-tree)))
    ;                   context)))))
    ;
    ;     (define binary-append
    ;       (lambda (x y)
    ;         (if (null? x)
    ;             y
    ;             (cons (kernel-car x)
    ;                   (binary-append (kernel-cdr x) y)))))
    ;
    ;     (define bounded-append
    ;       (lambda (k lss)
    ;         (if (<= k 0)
    ;             ()
    ;             (binary-append (kernel-car lss)
    ;                            (bounded-append (- k 1) (kernel-cdr lss))))))
    ;
    ;     (define finite-append
    ;       (lambda (lss)
    ;         (if (null? lss)
    ;             ()
    ;             (let ((ls   (kernel-car lss))
    ;                   (lss  (kernel-cdr lss)))
    ;               (if (null? lss)
    ;                   ls
    ;                   (binary-append ls (finite-append lss)))))))
    ;
    ;     (define set-last!
    ;       (lambda (x y)
    ;         (if (null? (kernel-cdr x))
    ;             (kernel-set-cdr! x y)
    ;             (set-last! (kernel-cdr x) y))))
    ;
    ;     (let* ((metrics  (get-list-metrics operand-tree))
    ;            (p        (car metrics))
    ;            (a        (caddr metrics))
    ;            (c        (cadddr metrics)))
    ;       (if (zero? c)
    ;           (begin
    ;             (check-operands (- p 1) 1 operand-tree)
    ;             (finite-append operand-tree))
    ;           (begin
    ;             (check-operands p 1 operand-tree)
    ;             (let ((cycle  (bounded-append c (kernel-list-tail
    ;                                               operand-tree a))))
    ;               (set-last! cycle cycle)
    ;               (if (zero? a)
    ;                   cycle
    ;                   (let ((acyclic-prefix
    ;                           (bounded-append a operand-tree)))
    ;                     (set-last! acyclic-prefix cycle)
    ;                     acyclic-prefix)))))))
    ;   0 -1)
    ;;;;;;;;;;;;

      'equal?  (binary-predicate->applicative  kernel-equal?  any?)

      )))

A  => subfiles/encapsulation.scm +65 -0
@@ 1,65 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 0)
             (list 0.1 0))
(set-revision-date 2007 8 4)

;;;;;;;;;;;;;;;;;;
; encapsulations ;
;;;;;;;;;;;;;;;;;;
;
; An encapsulation has type 'encapsulation, and attributes 'counter and 'value.
; When viewed from within Kernel, the counter is part of the type.
;
; Each call to procedure make-encapsualtion-type returns a matched set of
; encapsulator/type-predicate/decapsulator using a unique counter;
; the encapsulator manufactures encapsulations with that counter,
; the type-predicate returns true only for encapsulations with that counter,
; and the decapsulator only works on encapsulations with that counter.
;

(define make-encapsulation-type
  (let ((counter  0))
    (lambda ()
      (set! counter (+ counter 1))
      (let ((counter  counter))
        (let ((this-type?  (lambda (x)
                             (and (object? x)
                                  (eq? (x 'type) 'encapsulation)
                                  (= (x 'counter) counter)))))
          (kernel-list
            (naive->checked-applicative
              (lambda (operand-tree)
                (let ((value  (kernel-car operand-tree))
                      (name   (list #t)))
                  (lambda (message)
                    (case message
                      ((type)    'encapsulation)
                      ((name)    name)
                      ((counter) counter)
                      ((value)   value)))))
              "encapsulator"
              1 1)
            (unary-predicate->applicative this-type?)
            (naive->checked-applicative
              (lambda (operand-tree)
                ((kernel-car operand-tree) 'value))
              "decapsulator"
              1 1 this-type?)))))))

;
; Creates bindings for this type in a given environment.
;
; This code should not use any internal knowledge of the encapsulation type.
; It appears in this file, rather than in "subfiles/ground.scm", simply
; because it is logically associated with the encapsulation type.
;
(define bind-encapsulation-primitives!
  (lambda (env)
    (add-bindings! env

      'make-encapsulation-type
      (action->checked-applicative
        (lambda x (make-encapsulation-type))
        0 0))))

A  => subfiles/environment.scm +311 -0
@@ 1,311 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 1)
             (list 0.1 0))
(set-revision-date 2007 8 5)

;;;;;;;;;;;;;;;;
; environments ;
;;;;;;;;;;;;;;;;
;
; An environment has type 'environment, and attributes 'frames and 'alist.
;
;   'frames is a nonempty list of frames; a frame is a list of length one whose
; sole element is a list of name/value pairs.  Lookup starts with the first
; frame.  There should never be any reason to work with frames outside this
; file.
;
;   'alist is a list of keyed-bindings, constructed by tools in file
; "subfiles/keyed.scm".
;

;
; private constructor/accessors
;

(define internal-make-environment
  (lambda (frames alist)
    (let ((name  (list #t)))
      (lambda (message)
        (case message
          ((type)    'environment)
          ((name)    name)
          ((frames)  frames)
          ((alist)   alist))))))

(define get-environment-frames (lambda (x) (x 'frames)))
(define get-environment-alist  (lambda (x) (x 'alist)))

;
; public constructor/accessors
;

(define make-environment
  (lambda parents
    (internal-make-environment
      (cons (make-empty-frame)
            (apply append
                   (map get-environment-frames
                        parents)))
      (apply merge-alists
             (map get-environment-alist
                  parents)))))

(define make-standard-environment
  (lambda ()
    (make-environment ground-environment)))

(define make-environment-with-keyed-binding
  (lambda (key value parent)
    (internal-make-environment
      (cons (make-empty-frame) (get-environment-frames parent))
      (make-alist (get-environment-alist parent) key value))))

(define environment? (make-object-type-predicate 'environment))

(define environment-keyed-lookup
  (lambda (key env context)
    (let ((binding  (alist-lookup key (get-environment-alist env))))
      (if (pair? binding)
          (cdr binding)
          (error-pass
            (make-error-descriptor
              "Attempted to look up an unbound keyed static variable"
              (list "in " (list env)))
            context)))))

;
; Returns the value bound to name if there is one, otherwise throws an error.
;
(define lookup
  (lambda (name env context)
    (let ((binding  (get-binding-from-frames
                      name (get-environment-frames env))))
      (if (eq? binding #f)
          (error-pass
            (make-error-descriptor
              (list "Unbound symbol: " (symbol->string name))
              (list "in " (describe-object env)))
            context)
          (cdr binding)))))

;
; Performs a series of local bind operations, mutating existing local bindings
; when possible, creating new local bindings otherwise.  Takes an odd number of
; arguments, of which the even arguments are names (i.e., symbols).  The first
; argument is the environment in which local bindings are to be performed.
; Each later odd argument is the value to be locally bound to the immediately
; preceding name.
;
(define add-bindings!
  (lambda (env . x)
    (apply add-bindings-to-frame!
           (car (get-environment-frames env))
           x)))

;
; Removes local bindings for given symbols.  The first argument is the
; environment from which local bindings are to be removed, and each later
; argument is a symbol whose local binding, if any, is to be removed.
;
; This facility is not available to Kernel, but is used in
; "subfiles/ground.scm" to allow certain facilities to be provided
; temporarily in the ground environment while the Kernel library is being
; loaded, and then removed from the ground environment before entering the
; read-eval-print loop.
;
(define remove-bindings!
  (lambda (env . x)
    (apply remove-bindings-from-frame!
           (car (get-environment-frames env))
           x)))

;
; Determines whether a parameter tree is valid.
;
; A parameter tree is valid if it is acyclic, it contains no duplicate symbols,
; and every leaf is either a symbol, nil, or ignore.
;
(define valid-ptree?
  (lambda (tree)

    (define aux ; returns symbols if valid, #f if invalid
      (lambda (tree symbols)
        (cond ((ignore? tree)  symbols)
              ((null? tree)    symbols)
              ((symbol? tree)  (if (pair? (member tree symbols))
                                   #f
                                   (cons tree symbols)))
              ((kernel-pair? tree)
                 (let ((symbols  (aux (kernel-car tree) symbols)))
                   (if (eq? symbols #f)
                       #f
                       (aux (kernel-cdr tree) symbols))))
              (else  #f))))

    (and (not (cyclic-tree? tree))
         (list? (aux tree ())))))

;
; Locally binds a parameter-tree to an object.
;
; On success, returns nil.  On failure (invalid  parameter-tree, or
; parameter-tree/object mismatch), returns an error-descriptor to whose
; first line " when calling ..." might reasonably be appended.
;
(define match!
  (lambda (env ptree object)

    (define emsg ()) ; repository for error-descriptor content

    ; returns arguments for add-bindings-to-frame!
    (define aux
      (lambda (ptree object args)
        (cond ((kernel-pair? ptree)
                 (if (kernel-pair? object)
                     (aux      (kernel-cdr ptree) (kernel-cdr object)
                          (aux (kernel-car ptree) (kernel-car object) args))
                     (set! emsg
                           (append emsg
                                   (list (list "  mismatch:  " (list ptree)
                                               "  " (list object)))))))
              ((symbol? ptree)  (cons ptree (cons object args)))
              ((null? ptree)   (if (null? object)
                                   args
                                   (set! emsg
                                         (append emsg
                                            (list (list "  mismatch:  ()  "
                                                        (list object)))))))
              (else args)))) ; must be ignore

    (if (not (valid-ptree? ptree))
        (make-error-descriptor "Invalid parameter tree"
                               (list "Parameter tree: " (list ptree)))
        (let ((args  (aux ptree object ())))
          (if (pair? emsg)
              (apply make-error-descriptor
                     "Definiend/object mismatch"
                     (list "Definiend:  " (list ptree))
                     (list "Object:     " (list object))
                     (list)
                     emsg)
              (begin
                (apply add-bindings-to-frame!
                       (car (get-environment-frames env))
                       args)
                ()))))))

;
; Constructs an empty frame.
;
(define make-empty-frame (lambda () (list ())))

;
; Performs a series of bind operations in given frame, mutating existing
; bindings when possible, creating new bindings otherwise.  Arguments as
; add-bindings!, except that the first argument is the local frame.
;
(define add-bindings-to-frame!
  (lambda (frame . x)
    (if (pair? x)
        (let ((name   (car  x))
              (value  (cadr x))
              (x      (cddr x)))
          (if (object? value)
              (suggest-object-name value name))
          (let ((binding  (get-binding-from-frame name frame)))
            (if (eq? binding #f)
                (set-car! frame (cons (cons name value) (car frame)))
                (set-cdr! binding value)))
          (apply add-bindings-to-frame! frame x)))))

;
; Deletes bindings for given symbols from given frame.  Arguments as
; remove-bindings!, except that the first argument is the local frame.
;
(define remove-bindings-from-frame!
  (lambda (frame . x)

    (define aux-cdr!
      (lambda (bindings) ; must be a pair whose car has already been checked
        (cond ((null? (cdr bindings)))
              ((pair? (member (caadr bindings) x))
                 (set-cdr! bindings (cddr bindings))
                 (aux-cdr! bindings))
              (#t
                 (aux-cdr! (cdr bindings))))))

    (define aux-car!
      (lambda (frame)
        (cond ((null? (car frame)))
              ((pair? (member (caaar frame) x))
                 (set-car! frame (cdar frame))
                 (aux-car! frame))
              (#t
                 (aux-cdr! (car frame))))))

    (aux-car! frame)))

;
; Returns the binding for name if there is one, otherwise returns #f.
;
(define get-binding-from-frames
  (lambda (name frames)
    (if (null? frames)
        #f
        (let ((binding  (get-binding-from-frame name (car frames))))
          (if (pair? binding)
              binding
              (get-binding-from-frames name (cdr frames)))))))

;
; Returns the binding for name if there is one, otherwise returns #f.
;
(define get-binding-from-frame
  (lambda (name frame)
    (assoc name (car frame))))

;
; Creates bindings for this type in a given environment.
;
; This code should not use any internal knowledge of the environment type.
; It appears in this file, rather than in "subfiles/ground.scm", simply
; because it is logically associated with the type.
;
(define bind-environment-primitives!
  (lambda (env)
    (add-bindings! env

      'environment?
      (unary-predicate->applicative  environment?)

      'eval
      (action->checked-applicative
        (lambda (operand-tree env context)
          (eval (kernel-car operand-tree) (kernel-cadr operand-tree) context))
        2 2 any? environment?)

      'make-environment
      (naive->checked-applicative
        (lambda (operand-tree)
          (apply make-environment
                 (copy-kernel-list->list operand-tree)))
        "make-environment"
        0 -1 environment?)

      '$define!
      (action->checked-operative
        (lambda (operand-tree env context)
           (let ((ed  (match! env (kernel-car operand-tree)
                                  (eval (kernel-cadr operand-tree)
                                        env context))))
             (if (error-descriptor? ed)
                 (begin
                   (error-add-to-first-line!  ed
                     " when calling #[operative $define!]")
                   (error-pass ed context))
                 inert)))
        2 2)

      )))

A  => subfiles/error.scm +102 -0
@@ 1,102 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 2)
             (list 0.1 2))
(set-revision-date 2009 9 20)

;;;;;;;;;;;;;;;;;;;;
; error-descriptor ;
;;;;;;;;;;;;;;;;;;;;
;
; An error-descriptor has type 'error-descriptor, and attribute 'content whose
; value is a Scheme list of Scheme lists of line elements.  A line element is
; either a string, which is taken to be message text; or a Scheme list of one
; element, which is taken to be literal data.
;

(define make-error-descriptor
  (lambda content
    (let ((name     (list #t))
          (content  (map (lambda (x) (if (string? x) (list x) x)) content)))
      (lambda (message)
        (case message
          ((type)    'error-descriptor)
          ((name)    name)
          ((content) content))))))

(define error-descriptor? (make-object-type-predicate 'error-descriptor))

(define get-error-content (lambda (x) (x 'content)))

(define error-add-to-first-line!
  (lambda (ed . suffix)
    (let ((content  (get-error-content ed)))
      (set-car! content
                (append (car content) suffix)))))

;
; Describe an error.
;
; Since error descriptors can only be created directly by the interpreter,
; if the internal format is wrong, it's SINK's fault.
;
(define describe-error
  (lambda (error-descriptor)

    ; number of columns expended on strings on the current line
    (define column 0)

    ; single element on a line
    (define aux3
      (lambda (element)
        (cond ((string? element)
                 (let ((new-column  (+ column (string-length element))))
                   (if (< 79 new-column)
                       (begin
                         (newline)
                         (display " ;   ")
                         (set! column 5))
                       (set! column new-column)))
                 (display element))
              ((and (pair? element)
                    (null? (cdr element)))
                 (write-tree (car element) (current-output-port)))
              (else
                (display " [[")
                (write-tree element)
                (display "]] ")))))

    ; list of elements on a line
    (define aux2
      (lambda (ls)
        (if (pair? ls)
            (begin
              (aux3 (car ls))
              (aux2 (cdr ls))))))

    ; list of lines
    (define aux
      (lambda (lss)
        (if (pair? lss)
            (begin
              (display " ; ")
              (set! column 3)
              (aux2 (car lss))
              (newline)
              (aux (cdr lss))))))

    (aux (get-error-content error-descriptor))))

;
; Creates bindings for this type in a given environment.
;
; This code should not use any internal knowledge of the error-descriptor
; type.  It appears in this file, rather than in "subfiles/ground.scm", simply
; because it is logically associated with the inert type.
;
(define bind-error-descriptor-primitives!
  (lambda (env)
    (add-bindings! env

      'error-descriptor?  (unary-predicate->applicative error-descriptor?))))

A  => subfiles/eval.scm +62 -0
@@ 1,62 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 0)
             (list 0.1 0))
(set-revision-date 2007 8 4)

;;;;;;;;;;;;;;;;;;;;;;;;;;;
; evaluator central logic ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;

;
; Evaluate an expression in an environment, with given youngest enclosing
; context.  The normal result of evaluation is returned; contexts are only
; used for extraordinary purposes, i.e., Kernel abnormal passing of values
; or Kernel keyed dynamic bindings, so most theoretical Kernel contexts don't
; actually have to be constructed.
;
(define eval
  (lambda (exp env context)
    (cond ((kernel-pair? exp)  (combine (eval (kernel-car exp) env context)
                                        (kernel-cdr exp)
                                        env
                                        context))
          ((symbol? exp)  (lookup exp env context))
          (else exp))))

;
; Evaluate a combination in an environment,
; with given youngest enclosing context.
;
(define combine
  (lambda (combiner operand-tree env context)
    (cond ((operative? combiner)
             (operate combiner operand-tree env context))
          ((applicative? combiner)
             (combine (unwrap combiner)
                      (map-eval operand-tree env context combiner)
                      env
                      context))
          (else
             (error-pass (make-error-descriptor
                           (list "Tried to call a non-combiner: "
                                 (list combiner)))
                         context)))))

;
; Evaluate a list of expressions, and return a list of the results, with given
; youngest enclosing context; given also the applicative for which the list is
; being provided, just in case it's needed for an error message.
;
(define map-eval
  (lambda (operand-tree env context applicative)
    (if (not (kernel-list? operand-tree))
        (error-pass
          (make-error-descriptor
            (list "Operand tree not a list, passed to "
                  (describe-object applicative)))
          context)
        (simple-map
          (lambda (operand) (eval operand env context))
          operand-tree))))

A  => subfiles/ground.scm +238 -0
@@ 1,238 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.1 3))
(set-revision-date 2009 9 21)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Kernel ground environment ;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;
; The ground environment contains bindings for all built-in combiners.
;

(define ground-environment (make-environment))

;
; Evaluates a sequence of expressions, and returns the last result.
; Used by both $vau and $sequence.
;
(define eval-sequence
  (lambda (operand-tree env context)
    (cond ((null? operand-tree)  inert)
          ((not (kernel-pair? operand-tree))
             (error-pass
                (make-error-descriptor
                  "Non-list operand-tree when calling #[operative $sequence]")
                context))
          ((null? (kernel-cdr operand-tree))
             (eval (kernel-car operand-tree) env context))
          (else
             (eval          (kernel-car operand-tree) env context)
             (eval-sequence (kernel-cdr operand-tree) env context)))))

;
; Predicates the combiner type.
;
(define combiner? (make-object-type-predicate 'operative 'applicative))

;
; Predicates anything.
;
(define any? (lambda x #t))

;
; The primitive bindings.
;
; Many are enumerated here, especially those that are imported to Kernel from
; Scheme and those that aren't strongly associated with one of the other files.
; Others are handled by initializer procedures that were defined elsewhere.
;
(add-bindings! ground-environment

; 'combiner?   (unary-predicate->applicative  combiner?)

  'char?       (unary-predicate->applicative  char?)
  'eof-object? (unary-predicate->applicative  eof-object?)
  'eq?         (binary-predicate->applicative eq?          any?)
  'null?       (unary-predicate->applicative  null?)
  'string?     (unary-predicate->applicative  string?)
  'symbol?     (unary-predicate->applicative  symbol?)

  'string=?     (binary-predicate->applicative  string=?      string?)
  'string<?     (binary-predicate->applicative  string<?      string?)
  'string>?     (binary-predicate->applicative  string>?      string?)
  'string<=?    (binary-predicate->applicative  string<=?     string?)
  'string>=?    (binary-predicate->applicative  string>=?     string?)
  'string-ci=?  (binary-predicate->applicative  string-ci=?   string?)
  'string-ci<?  (binary-predicate->applicative  string-ci<?   string?)
  'string-ci>?  (binary-predicate->applicative  string-ci>?   string?)
  'string-ci<=? (binary-predicate->applicative  string-ci<=?  string?)
  'string-ci>=? (binary-predicate->applicative  string-ci>=?  string?)

  'string-append
  (naive->checked-applicative
    (lambda (operand-tree)
      (apply string-append
             (copy-kernel-list->list operand-tree)))
    "string-append"
    0 -1 string?)

  'number->string
  (naive->checked-applicative
    (lambda (operand-tree)
      (let ((number  (kernel-car operand-tree)))
        (if (object? number)
            (string-copy (describe-object number))
            (number->string number))))
    "number->string"
    1 1 kernel-number?)

  'list->string
  (naive->checked-applicative
    (lambda (operand-tree)
      (list->string (kernel-list->list (kernel-car operand-tree))))
    "list->string"
    1 1 kernel-list?)

  'integer->char
  (naive->checked-applicative
    (lambda (operand-tree)
      (integer->char (kernel-car operand-tree)))
    "integer->char"
    1 1 integer?)

  'char->integer
  (naive->checked-applicative
    (lambda (operand-tree)
      (char->integer (kernel-car operand-tree)))
    "char->integer"
    1 1 char?)

;;;;;;;;;;;; doesn't look right
;  'assoc
;  (naive->checked-applicative
;    (lambda (operand-tree)
;      (let* ((key     (kernel-car operand-tree))
;             (alist   (kernel-cadr operand-tree))
;             (result  (assoc key (kernel-list->list alist))))
;        (if (pair? result)
;            result
;            ())))
;    "assoc"
;    2 2 any? kernel-list?)
;;;;;;;;;;;;

;  'assq
;  (naive->checked-applicative
;    (lambda (operand-tree)
;      (let* ((key     (kernel-car operand-tree))
;             (alist   (kernel-cadr operand-tree))
;             (result  (assq key (kernel-list->list alist))))
;        (if (pair? result)
;            result
;            ())))
;    "assq"
;    2 2 any? kernel-list?)

; '$sequence
; (action->operative eval-sequence)

  'load
  (action->checked-applicative
    (lambda (operand-tree env context)
      (let* ((filename  (kernel-car operand-tree))
             (kip       (open-kernel-input-file filename context)))
        (suggest-object-name kip (string-append "\"" filename "\""))
        (call-with-guarded-context
          (lambda (context)
            (letrec ((aux  (lambda (legacy)
                             (let ((object  (copy-es-immutable
                                              (kernel-read kip context))))
                               (if (eof-object? object)
                                   (begin
                                     (close-kernel-input-port kip context)
                                     legacy)
                                   (aux (eval object env context)))))))
              (aux inert)))
          context
          (list (cons ()
                      (lambda (v)
                        (error-pass
                          (make-error-descriptor
                            (list "Tried to reenter dynamic extent of load \""
                                  filename "\"")
                            (list "  Value sent: " (list v)))
                          context))))
          (list (cons ()
                      (lambda (v)
                        (close-kernel-input-port kip context)
                        v))))))
    1 1 string?)

  ;
  ; Finally, these bindings are added to the ground environment temporarily,
  ; for use in "subfiles/library.snk" so that it can contribute to the version
  ; number and date.  They are removed from the ground environment after the
  ; library has been loaded.
  ;

  '$set-version
  (naive->checked-operative
    (lambda (operand-tree)
      (apply set-version
        (map kernel-list->list (kernel-list->list operand-tree))))
    "$set-version"
    0 -1 (lambda (x) (and (kernel-pair? x) (kernel-pair? (kernel-cdr x)))))

  '$set-revision-date
  (naive->checked-operative
    (lambda (operand-tree)
      (apply set-revision-date (kernel-list->list operand-tree)))
    "$set-revision-date"
    3 3 integer?)

  )

(bind-applicative-primitives!      ground-environment)
(bind-boolean-primitives!          ground-environment)
(bind-context-primitives!          ground-environment)
(bind-cyclic-primitives!           ground-environment)
(bind-encapsulation-primitives!    ground-environment)
(bind-environment-primitives!      ground-environment)
(bind-error-descriptor-primitives! ground-environment)
(bind-ignore-primitives!           ground-environment)
(bind-inert-primitives!            ground-environment)
(bind-kernel-pair-primitives!      ground-environment)
(bind-keyed-variable-primitives!   ground-environment)
(bind-number-primitives!           ground-environment)
(bind-operative-primitives!        ground-environment)
(bind-port-primitives!             ground-environment)

;
; The library bindings.
;
; This code loads the Kernel library.  Since loading involves evaluation, it
; has to create a top-level context, and in case an error message must be
; generated during the load it also names the ground environment; the code
; is therefore rather similar to that of interpreter, in file
; "subfiles/interpreter.scm".  After loading the library, bindings for
; symbols "set-version" and "set-revision-date" are removed from the ground
; environment (since they aren't meant to be available to Kernel programs).
;

(let ((okay  #t))
  (suggest-object-name ground-environment 'the-ground-environment)
  (let ((context  (make-top-level-context
                    (lambda (x)
                      (report-error x)
                      (set! okay #f)))))
    (if okay
        (begin
          (eval (list->kernel-list '(load "subfiles/library.snk"))
                ground-environment context)
          (remove-bindings! ground-environment
                            '$set-version
                            '$set-revision-date)
          ))))

A  => subfiles/ignore.scm +35 -0
@@ 1,35 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 0)
             (list 0.1 0))
(set-revision-date 2007 8 4)

;;;;;;;;;;
; ignore ;
;;;;;;;;;;
;
; The ignore value has type 'ignore and no attributes.
;

(define ignore (let ((name  (list #f)))
                 (lambda (message)
                   (case message
                     ((type) 'ignore)
                     ((name) name)))))

(define ignore? (make-object-type-predicate 'ignore))

;
; Creates bindings for this type in a given environment.
;
; This code should not use any internal knowledge of the ignore type (not
; that there's anything much to use).  It appears in this file, rather than
; in "subfiles/ground.scm", simply because it is logically associated with
; the ignore type.
;
(define bind-ignore-primitives!
  (lambda (env)
    (add-bindings! env

      'ignore?  (unary-predicate->applicative ignore?))))

A  => subfiles/inert.scm +35 -0
@@ 1,35 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 0)
             (list 0.1 0))
(set-revision-date 2007 8 4)

;;;;;;;;;
; inert ;
;;;;;;;;;
;
; The inert value has type 'inert and no attributes.
;

(define inert (let ((name  (list #f)))
                (lambda (message)
                  (case message
                    ((type) 'inert)
                    ((name) name)))))

(define inert? (make-object-type-predicate 'inert))

;
; Creates bindings for this type in a given environment.
;
; This code should not use any internal knowledge of the inert type (not
; that there's anything much to use).  It appears in this file, rather than
; in "subfiles/ground.scm", simply because it is logically associated with
; the inert type.
;
(define bind-inert-primitives!
  (lambda (env)
    (add-bindings! env

      'inert?  (unary-predicate->applicative inert?))))

A  => subfiles/interpreter.scm +68 -0
@@ 1,68 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 0)
             (list 0.1 0))
(set-revision-date 2007 8 4)

;;;;;;;;;;;;;;;;;;;;;;;;;
; interpreter top level ;
;;;;;;;;;;;;;;;;;;;;;;;;;
;
; Although this file contains the top-level interpreter, it isn't the top-level
; file; it is just one of the files loaded by "sink.scm".
;
; The interpreter is a read-eval-print loop run on a child of the ground
; environment.  The top-level context always returns to the point where the
; interpreter ordered its construction, causing the inner let to rebind its
; symbol "context" and re-run its body, (if (context? context) ...).
;
(define interpreter
  (lambda ()
    (let ((env  (make-standard-environment)))
      (suggest-object-name env 'the-global-environment)
      (let ((context  (make-top-level-context report-error)))
        (if (context? context)
            (begin
              (initialize-context-bindings ground-environment context)
              (rep-loop env context))
            'SINK-terminated)))))

;
; The read-eval-print loop, parameterized by the global environment and the
; top-level context.
;
(define rep-loop
  (lambda (env context)
    (display ">> ")
    (let ((exp  (kernel-read (get-kernel-current-input-port context)
                             context)))
      (newline)
      (if (eof-object? exp)
          (terminal-pass () context))
      (kernel-write (eval exp env context)
                    (get-kernel-current-output-port context)
                    context)
      (newline)
      (newline)
      (rep-loop env context))))

;
; Reports an error, based on a descriptor argument.
;
; Ideally, the argument would always be an error-descriptor (cf. file
; "subfiles/error.scm"); but then, ideally there would be no need for an error
; handler.  If the argument isn't an error-descriptor, that fact is reported
; along with the argument.
;
(define report-error
  (lambda (x)
    (if (error-descriptor? x)
        (describe-error x)
        (begin
          (display " ; error, general handler given non-descriptor object:")
          (newline)
          (display " ; ")
          (display-tree x (current-output-port))
          (newline)))
    (newline)))

A  => subfiles/kernel-pair-disjoint.scm +496 -0
@@ 1,496 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 1)
             (list 0.1 1))
(set-revision-date 2009 9 1)

;;;;;;;;;
; pairs ;
;;;;;;;;;
;
; Pairs in the interpreted language ("Kernel") are a different data type from
; pairs in the meta-language (Scheme).  The interpreted-language type is
; called "kernel-pair".  Outside of this file, types pair and kernel-pair
; cannot be assumed to be identical, nor can they be assumed to be disjoint.
;
; The interpreted language has both mutable and immutable kernel-pairs.
; Their subtypes are called respectively "mutable" and "immutable".
; Private to this file, immutables are disjoint from pairs, while two
; different implementations are possible for mutables, one in which mutables
; are actually pairs (unbeknownst to the rest of the interpreter), the other
; in which they too are disjoint from pairs.
;
; When a procedure for kernel-pairs is cognate to one for pairs, it is named
; by adding prefix "kernel-" to the Scheme name:  kernel-cons, kernel-car,
; kernel-cdr, kernel-caar, etc.
;
; The only constructor of immutables is copy-es-immutable, which returns an
; immutable copy of a kernel-pair and all other kernel-pairs reachable from
; it without passing through any non-kernel-pair.  Consequently, it is not
; possible for an immutable to have a mutable as its kernel-car or kernel-cdr.
;
; Type kernel-list differs from type list both by using kernel-pairs instead of
; pairs, and by allowing cycles.  An "improper kernel-list" doesn't have to be
; null-terminated, therefore all Kernel values are improper kernel-lists.
; Similarly, every Kernel value is a kernel-tree; but Scheme trees aren't used
; in the interpreter, so kernel-trees are called simply "trees".
;
;
; Implementing mutables disjointly is more expensive than implementing
; immutables that way, because there is usually just one immutable copy of an
; algorithm, but during evaluation of that one copy, many mutable argument
; lists are constructed.  On the other hand, if mutables are represented by
; pairs, it is appallingly easy for code elsewhere in the interpreter to treat
; Kernel structures as if they were Scheme structures, without the bug being
; detected for a long time.  Both implementations have been provided, one in
; file "subfiles/kernel-pair-disjoint.scm" and the other in file
; "subfiles/kernel-pair-overlapping.scm"; the file loaded by the interpreter,
; called "subfiles/kernel-pair.scm", is a copy of one or the other version.
;
; This is the disjoint version of the type.  A mutable kernel-pair is an object
; with type 'mutable and attribute 'kar, 'kdr, and 'content, where 'content is
; a pair whose car and cdr are returned by 'kar and 'kdr.  An immutable
; kernel-pair is an object with type 'immutable and attributes 'kar and 'kdr.
;

(define mutable? (make-object-type-predicate 'mutable))

(define immutable? (make-object-type-predicate 'immutable))

(define kernel-pair?
  (lambda (x)
    (or (mutable? x)
        (immutable? x))))

(define kernel-car
  (lambda (x)
    (x 'kar)))

(define kernel-cdr
  (lambda (x)
    (x 'kdr)))

(define kernel-caar (lambda (x) (kernel-car (kernel-car x))))
(define kernel-cadr (lambda (x) (kernel-car (kernel-cdr x))))
(define kernel-cddr (lambda (x) (kernel-cdr (kernel-cdr x))))
(define kernel-caddr (lambda (x) (kernel-car (kernel-cdr (kernel-cdr x)))))
(define kernel-cadddr
  (lambda (x) (kernel-car (kernel-cdr (kernel-cdr (kernel-cdr x))))))

(define kernel-cons
  (lambda (kar kdr)
    (let ((name     (list #t))
          (content  (cons kar kdr)))
      (lambda (message)
        (case message
          ((type)    'mutable)
          ((name)    name)
          ((kar)     (car content))
          ((kdr)     (cdr content))
          ((content) content))))))

(define kernel-list
  (lambda x
    (if (pair? x)
        (kernel-cons (car x) (apply kernel-list (cdr x)))
        x)))

(define kernel-set-car!
  (lambda (kernel-pair kar)
    (set-car! (kernel-pair 'content) kar)))

(define kernel-set-cdr!
  (lambda (kernel-pair kdr)
    (set-cdr! (kernel-pair 'content) kdr)))

;
; Constructs a procedure that takes as its sole argument a possibly-cyclic
; structure composed from some pair-like primitive data type, and returns a
; list of nodes of the structure (i.e., pair-like entities) whose revisits
; should be pruned during traversal of the structure.
;
; The precise condition that should be satisfied by the result is that the
; listed revisits are a minimal set sufficient to minimize a traversal of the
; structure.
;   "Sufficient to minimize a traversal" means that, if the structure were
; traversed, checking each node against the revisits-list; and at the first
; position where a listed node is visited, traversal would continue past it to
; its descendants, but at other positions where it occurs, traversal would not
; continue past it; then this traversal would visit every node of the
; structure at least once, and would revisit only nodes on the revisits-list.
;   "Minimal set" means that if any member of the revisits-list were removed,
; then it would no longer have this property, i.e., it would no longer be
; sufficient to minimize a traversal.
;
; The purpose of this condition is to all clients to preserve structural
; isomorphism.  This is a strictly more difficult task than merely preventing
; infinite traversal of cyclic structures.  For example, commands
;   ($define! x (list 1 2 3))
;   (set-car! x (cdr x))
; would produce acyclic structure  (#1=(2 3) . #1#)  whose revisit-list would
; be a singleton list of node #1#.  Merely to prevent infinite traversals,
; it would suffice to check each node against its ancestors; but that would
; not detect the redundancy in this example, so that any structural
; transformation based on such an algorithm could not be expected to produce
; a structurally isomorphic result.
;
; Arguments:
;   tree               --- the structure itself, composed of pair-like nodes
;   node?              --- predicate for the pair-like type
;   node-car, node-cdr --- accessors for the pair-like type
;
(define make-get-revisits
  (lambda (node? node-car node-cdr)

    (define aux
      (lambda (revisits all . trees)
        (if (null? trees)
            revisits
            (let ((tree   (car trees))
                  (trees  (cdr trees)))
              (cond ((or (not (node? tree))
                         (pair? (memq tree revisits)))
                       (apply aux revisits all trees))
                    ((pair? (memq tree all))
                       (apply aux (cons tree revisits) all trees))
                    (else
                       (apply aux revisits (cons tree all)
                                  (node-car tree) (node-cdr tree) trees)))))))

    ; get-revisits
    (lambda (tree)
      (aux () () tree))))

(define get-kernel-revisits
  (make-get-revisits kernel-pair? kernel-car kernel-cdr))

;
; Constructs a procedure that takes as its sole argument a possibly-cyclic
; structure composed from some pair-like primitive data type, and returns
; a structurally isomorphic copy of its evaluation structure, optionally
; performing some transformation on leaf nodes during the copy.
;
; There will be three such procedures constructed:
; copy-es-immutable, copy-es, and scheme-read-object->kernel.
;
; The evaluation structure of a value (under a given pair-like primitive type)
; is the structure whose start is the value itself, and whose members are all
; objects reachable from the start by following only car and cdr references
; (of the given pair-like primitive type).  If the value is not of the
; chosen pair-like type, then the value itself is the only object of the
; data structure.
;
; Arguments:
;     in-pair?       --- predicate for the input pair-like type
;     in-car, in-cdr --- accessors for the input pair-like type
;     make-record    --- constructs an alist record (see below)
;     out-cons       --- constructs a copy of a non-pruned parent node
;     xform-leaf     --- transformation to perform on leaves when copying
;
; First, compiles an alist whose keys are those in-pairs in the input
; structure whose cyclic revisiting must be pruned during traversal.  For
; each of these in-pairs, make-record constructs an alist record whose key
; is the in-pair, whose cadr is an out-pair, and whose cddr is a pair whose
; elements determine the out-car and out-cdr of the out-pair.  (Depending on
; representations, the cadr and cddr might actually be the same object.)  Then
; the in-pairs of the input structure are traversed a second time, creating
; out-pairs for non-pruned mutables using out-cons, and setting the elements
; of the previously constructed out-pairs for pruned in-pairs.  When the
; elements of a pruned out-pair are to be set, its content pair is separated
; out and the cddr of its record is set to nil, to prevent infinite recursion.
;
(define make-es-copier
  (lambda (in-pair? in-car in-cdr make-record out-cons xform-leaf)

    (define get-in-revisits (make-get-revisits in-pair? in-car in-cdr))

    ; es-copier
    (lambda (tree)

      (define alist (map make-record (get-in-revisits tree)))

      (define aux
        (lambda (tree)
          (if (not (in-pair? tree))
              (xform-leaf tree)
              (let ((record  (assq tree alist)))
                (if (pair? record)
                    (let ((content  (cddr record)))
                      (if (pair? content)
                          (begin
                            (set-cdr! (cdr record) ())
                            (set-car! content (aux (in-car tree)))
                            (set-cdr! content (aux (in-cdr tree)))))
                      (cadr record))
                    (out-cons (aux (in-car tree))
                              (aux (in-cdr tree))))))))

      (aux tree))))

;
; Given a Kernel value, returns an immutable copy of its evaluation structure.
;
(define copy-es-immutable
  (make-es-copier
    mutable? kernel-car kernel-cdr
    (let ((name  (list #f)))
      (lambda (key)
        (let ((content  (cons () ())))
          (let ((immutable  (lambda (message)
                              (case message
                                ((type) 'immutable)
                                ((name) name)
                                ((kar)  (car content))
                                ((kdr)  (cdr content))))))
            (cons key
                  (cons immutable content))))))
    (let ((name  (list #f)))
      (lambda (kar kdr)
        (lambda (message)
          (case message
            ((type) 'immutable)
            ((name) name)
            ((kar)  kar)
            ((kdr)  kdr)))))
    (lambda (x) x)))

;
; Given a Kernel value, returns a mutable copy of its evaluation structure.
;
(define copy-es
  (make-es-copier
    kernel-pair? kernel-car kernel-cdr
    (lambda (key)
      (let* ((kernel-pair  (kernel-cons () ()))
             (content      (kernel-pair 'content)))
        (cons key (cons kernel-pair content))))
    kernel-cons
    (lambda (x) x)))

;
; Given a scheme value presumed to have just been read, returns a mutable
; Kernel version of the value, by copying its evaluation structure and
; transforming certain symbols to their Kernel counterparts.
;
(define scheme-read-object->kernel
  (make-es-copier
    pair? car cdr
    (lambda (key)
      (let* ((kernel-pair  (kernel-cons () ()))
             (content      (kernel-pair 'content)))
        (cons key (cons kernel-pair content))))
    kernel-cons
    (lambda (x)
      (if (symbol? x)
          (case x
            ((%ignore) ignore)
            ((%inert)  inert)
            ((%e+infinity)  exact-positive-infinity)
            ((%e-infinity)  exact-negative-infinity)
            ((%i+infinity)  inexact-positive-infinity)
            ((%i-infinity)  inexact-negative-infinity)
            (else      x))
          x))))

;
; Given a kernel-list, returns a list with the same elements in the same order.
; The result is guaranteed to be a list (acyclic and made up of pairs), but is
; not guaranteed to be distinct from the given kernel-list:  if mutables are
; represented by pairs, the result may be the given kernel-list.  Therefore,
; this tool should only be used if the resultant list certainly will not be
; mutated (because mutating the result might mutate the original kernel-list).
;
; To guarantee that the result will be distinct from the argument,
; use  copy-kernel-list->list.
;
(define kernel-list->list
  (lambda (ls)
    (copy-kernel-list->list ls)))

;
; Given a list, returns a mutable kernel-list with the same elements in the
; same order.  The elements are assumed to be kernel values.  The result is
; not guaranteed to be distinct from the given list:  if mutables are
; represented by pairs, the result may be the given kernel-list.  Therefore,
; this tool should only be used if the given list won't be needed again
; (so that if it happens to be mutated, that won't be a problem).
;
(define list->kernel-list
  (lambda (ls)
    (if (null? ls)
        ls
        (kernel-cons (car ls)
                     (list->kernel-list (cdr ls))))))

;
; Determines whether a tree (i.e., an arbitrary interpreted-language value)
; is cyclic.
;
(define cyclic-tree?
  (lambda (tree)

    (define aux
      (lambda (ancestors tree)
        (cond ((not (kernel-pair? tree))  #f)
              ((pair? (memq tree ancestors))  #t)
              (else
                (let ((ancestors  (cons tree ancestors)))
                  (or (aux ancestors (kernel-car tree))
                      (aux ancestors (kernel-cdr tree))))))))

    (aux () tree)))

;
; Given a tree of the interpreted language, output a representation of it to
; a given output-port, using a given procedure to output the non-object leaves.
; The latter takes as arguments the leaf and the output-port.  Either the third
; argument, or the second and third arguments, may be omitted.  If the third
; argument is omitted, write is used.  If the second argument is also omitted,
; the current output-port is used.
;
; Cyclicity is handled by keeping an alist of revisits (kernel-pairs that will
; be visited more than once and are to be expanded only on the first visit),
; where the cadr of each record is the position of the record in the alist,
; and the cddr of the record is #t or #f depending on whether that revisit has
; already been expanded once.
;
(define write-tree
  (lambda (x . options)
    (let ((outport     (if (pair? options)
                           (car options)
                           (current-output-port)))
          (write-leaf  (if (and (pair? options) (pair? (cdr options)))
                           (cadr options)
                           write))
          (table  (letrec ((aux  (lambda (ls k)
                                   (if (null? ls)
                                       ls
                                       (cons (cons (car ls) (cons k #f))
                                             (aux (cdr ls) (+ k 1)))))))
                    (aux (get-kernel-revisits x) 0))))

      (define write-visit
        (lambda (x rec)
          (display "#"        outport)
          (display (cadr rec) outport)
          (if (cddr rec)
              (display "#" outport)
              (begin
                (set-cdr! (cdr rec) #t)
                (display   "=(" outport)
                (write-car (kernel-car x))
                (write-cdr (kernel-cdr x))
                (display   ")" outport)))))

      (define write-cdr
        (lambda (x)
          (cond ((null? x))
                ((kernel-pair? x)
                   (let ((rec  (assq x table)))
                     (if (pair? rec)
                         (begin
                           (display     " . " outport)
                           (write-visit x rec))
                         (begin
                           (display   " " outport)
                           (write-car (kernel-car x))
                           (write-cdr (kernel-cdr x))))))
                (else
                   (display   " . " outport)
                   (write-car x)))))

      (define write-car
        (lambda (x)
          (cond ((kernel-pair? x)
                   (let ((rec  (assq x table)))
                     (if (pair? rec)
                         (write-visit x rec)
                         (begin
                           (display   "(" outport)
                           (write-car (kernel-car x))
                           (write-cdr (kernel-cdr x))
                           (display   ")" outport)))))
                ((object? x)  (display (describe-object x) outport))
                ((pair? x)
                   (display "#[misplaced meta-language structure: ")
                   (write x)
                   (display "]"))
                (else  (write-leaf x outport)))))

      (write-car x))))

;
; As write-tree, except that there must be exactly two arguments, and the
; non-object leaf output procedure is display rather than write.
;
(define display-tree
  (lambda (x outport)
    (write-tree x outport display)))

;
; Creates bindings for this type in a given environment.
;
; This code should not use any internal knowledge of the kernel-pair type.
; It appears in this file, rather than in "subfiles/ground.scm", simply
; because it is logically associated with the kernel-pair type.
;
(define bind-kernel-pair-primitives!
  (lambda (env)
    (add-bindings! env

      'pair? (unary-predicate->applicative  kernel-pair?)

      'cons
      (naive->checked-applicative
        (lambda (operand-tree)
          (kernel-cons (kernel-car operand-tree)
                       (kernel-cadr operand-tree)))
        "cons"
        2 2)

      'copy-es-immutable
      (naive->checked-applicative
        (lambda (operand-tree)
          (copy-es-immutable (kernel-car operand-tree)))
        "copy-es-immutable"
        1 1)

      'copy-es
      (naive->checked-applicative
        (lambda (operand-tree)
          (copy-es (kernel-car operand-tree)))
        "copy-es"
        1 1)

      'set-car!
      (action->checked-applicative
        (lambda (operand-tree env context)
          (let ((x  (kernel-car operand-tree))
                (y  (kernel-cadr operand-tree)))
            (if (mutable? x)
                (kernel-set-car! x y)
                (error-pass (make-error-descriptor
                              (list "Operand #1 is immutable"
                                    " when calling primitive set-car!")
                              (list "Operand tree: " (list operand-tree)))
                            context)))
          inert)
        2 2 kernel-pair? any?)

      'set-cdr!
      (action->checked-applicative
        (lambda (operand-tree env context)
          (let ((x  (kernel-car operand-tree))
                (y  (kernel-cadr operand-tree)))
            (if (mutable? x)
                (kernel-set-cdr! x y)
                (error-pass (make-error-descriptor
                              (list "Operand #1 is immutable"
                                    " when calling primitive set-cdr!")
                              (list "Operand tree: " (list operand-tree)))
                            context)))
          inert)
        2 2 kernel-pair? any?)

      )))

A  => subfiles/kernel-pair-overlapping.scm +477 -0
@@ 1,477 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 1)
             (list 0.1 1))
(set-revision-date 2009 9 1)

;;;;;;;;;
; pairs ;
;;;;;;;;;
;
; Pairs in the interpreted language ("Kernel") are a different data type from
; pairs in the meta-language (Scheme).  The interpreted-language type is
; called "kernel-pair".  Outside of this file, types pair and kernel-pair
; cannot be assumed to be identical, nor can they be assumed to be disjoint.
;
; The interpreted language has both mutable and immutable kernel-pairs.
; Their subtypes are called respectively "mutable" and "immutable".
; Private to this file, immutables are disjoint from pairs, while two
; different implementations are possible for mutables, one in which mutables
; are actually pairs (unbeknownst to the rest of the interpreter), the other
; in which they too are disjoint from pairs.
;
; When a procedure for kernel-pairs is cognate to one for pairs, it is named
; by adding prefix "kernel-" to the Scheme name:  kernel-cons, kernel-car,
; kernel-cdr, kernel-caar, etc.
;
; The only constructor of immutables is copy-es-immutable, which returns an
; immutable copy of a kernel-pair and all other kernel-pairs reachable from
; it without passing through any non-kernel-pair.  Consequently, it is not
; possible for an immutable to have a mutable as its kernel-car or kernel-cdr.
;
; Type kernel-list differs from type list both by using kernel-pairs instead of
; pairs, and by allowing cycles.  An "improper kernel-list" doesn't have to be
; null-terminated, therefore all Kernel values are improper kernel-lists.
; Similarly, every Kernel value is a kernel-tree; but Scheme trees aren't used
; in the interpreter, so kernel-trees are called simply "trees".
;
;
; Implementing mutables disjointly is more expensive than implementing
; immutables that way, because there is usually just one immutable copy of an
; algorithm, but during evaluation of that one copy, many mutable argument
; lists are constructed.  On the other hand, if mutables are represented by
; pairs, it is appallingly easy for code elsewhere in the interpreter to treat
; Kernel structures as if they were Scheme structures, without the bug being
; detected for a long time.  Both implementations have been provided, one in
; file "subfiles/kernel-pair-disjoint.scm" and the other in file
; "subfiles/kernel-pair-overlapping.scm"; the file loaded by the interpreter,
; called "subfiles/kernel-pair.scm", is a copy of one or the other version.
;
; This is the overlapping version of the type.  A mutable kernel-pair is a
; pair; an immutable kernel-pair is an object with type 'immutable and
; attributes 'kar and 'kdr.
;

(define mutable? pair?)

(define immutable? (make-object-type-predicate 'immutable))

(define kernel-pair?
  (lambda (x)
    (or (mutable? x)
        (immutable? x))))

(define kernel-car
  (lambda (x)
    (if (pair? x)
        (car x)
        (x 'kar))))

(define kernel-cdr
  (lambda (x)
    (if (pair? x)
        (cdr x)
        (x 'kdr))))

(define kernel-caar (lambda (x) (kernel-car (kernel-car x))))
(define kernel-cadr (lambda (x) (kernel-car (kernel-cdr x))))
(define kernel-cddr (lambda (x) (kernel-cdr (kernel-cdr x))))
(define kernel-caddr (lambda (x) (kernel-car (kernel-cdr (kernel-cdr x)))))
(define kernel-cadddr
  (lambda (x) (kernel-car (kernel-cdr (kernel-cdr (kernel-cdr x))))))

(define kernel-cons  cons)

(define kernel-list
  (lambda x
    (if (pair? x)
        (kernel-cons (car x) (apply kernel-list (cdr x)))
        x)))

(define kernel-set-car!  set-car!)
(define kernel-set-cdr!  set-cdr!)

;
; Constructs a procedure that takes as its sole argument a possibly-cyclic
; structure composed from some pair-like primitive data type, and returns a
; list of nodes of the structure (i.e., pair-like entities) whose revisits
; should be pruned during traversal of the structure.
;
; The precise condition that should be satisfied by the result is that the
; listed revisits are a minimal set sufficient to minimize a traversal of the
; structure.
;   "Sufficient to minimize a traversal" means that, if the structure were
; traversed, checking each node against the revisits-list; and at the first
; position where a listed node is visited, traversal would continue past it to
; its descendants, but at other positions where it occurs, traversal would not
; continue past it; then this traversal would visit every node of the
; structure at least once, and would revisit only nodes on the revisits-list.
;   "Minimal set" means that if any member of the revisits-list were removed,
; then it would no longer have this property, i.e., it would no longer be
; sufficient to minimize a traversal.
;
; The purpose of this condition is to all clients to preserve structural
; isomorphism.  This is a strictly more difficult task than merely preventing
; infinite traversal of cyclic structures.  For example, commands
;   ($define! x (list 1 2 3))
;   (set-car! x (cdr x))
; would produce acyclic structure  (#1=(2 3) . #1#)  whose revisit-list would
; be a singleton list of node #1#.  Merely to prevent infinite traversals,
; it would suffice to check each node against its ancestors; but that would
; not detect the redundancy in this example, so that any structural
; transformation based on such an algorithm could not be expected to produce
; a structurally isomorphic result.
;
; Arguments:
;   tree               --- the structure itself, composed of pair-like nodes
;   node?              --- predicate for the pair-like type
;   node-car, node-cdr --- accessors for the pair-like type
;
(define make-get-revisits
  (lambda (node? node-car node-cdr)

    (define aux
      (lambda (revisits all . trees)
        (if (null? trees)
            revisits
            (let ((tree   (car trees))
                  (trees  (cdr trees)))
              (cond ((or (not (node? tree))
                         (pair? (memq tree revisits)))
                       (apply aux revisits all trees))
                    ((pair? (memq tree all))
                       (apply aux (cons tree revisits) all trees))
                    (else
                       (apply aux revisits (cons tree all)
                                  (node-car tree) (node-cdr tree) trees)))))))

    ; get-revisits
    (lambda (tree)
      (aux () () tree))))

(define get-kernel-revisits
  (make-get-revisits kernel-pair? kernel-car kernel-cdr))

;
; Constructs a procedure that takes as its sole argument a possibly-cyclic
; structure composed from some pair-like primitive data type, and returns
; a structurally isomorphic copy of its evaluation structure, optionally
; performing some transformation on leaf nodes during the copy.
;
; There will be three such procedures constructed:
; copy-es-immutable, copy-es, and scheme-read-object->kernel.
;
; The evaluation structure of a value (under a given pair-like primitive type)
; is the structure whose start is the value itself, and whose members are all
; objects reachable from the start by following only car and cdr references
; (of the given pair-like primitive type).  If the value is not of the
; chosen pair-like type, then the value itself is the only object of the
; data structure.
;
; Arguments:
;     in-pair?       --- predicate for the input pair-like type
;     in-car, in-cdr --- accessors for the input pair-like type
;     make-record    --- constructs an alist record (see below)
;     out-cons       --- constructs a copy of a non-pruned parent node
;     xform-leaf     --- transformation to perform on leaves when copying
;
; First, compiles an alist whose keys are those in-pairs in the input
; structure whose cyclic revisiting must be pruned during traversal.  For
; each of these in-pairs, make-record constructs an alist record whose key
; is the in-pair, whose cadr is an out-pair, and whose cddr is a pair whose
; elements determine the out-car and out-cdr of the out-pair.  (Depending on
; representations, the cadr and cddr might actually be the same object.)  Then
; the in-pairs of the input structure are traversed a second time, creating
; out-pairs for non-pruned mutables using out-cons, and setting the elements
; of the previously constructed out-pairs for pruned in-pairs.  When the
; elements of a pruned out-pair are to be set, its content pair is separated
; out and the cddr of its record is set to nil, to prevent infinite recursion.
;
(define make-es-copier
  (lambda (in-pair? in-car in-cdr make-record out-cons xform-leaf)

    (define get-in-revisits (make-get-revisits in-pair? in-car in-cdr))

    ; es-copier
    (lambda (tree)

      (define alist (map make-record (get-in-revisits tree)))

      (define aux
        (lambda (tree)
          (if (not (in-pair? tree))
              (xform-leaf tree)
              (let ((record  (assq tree alist)))
                (if (pair? record)
                    (let ((content  (cddr record)))
                      (if (pair? content)
                          (begin
                            (set-cdr! (cdr record) ())
                            (set-car! content (aux (in-car tree)))
                            (set-cdr! content (aux (in-cdr tree)))))
                      (cadr record))
                    (out-cons (aux (in-car tree))
                              (aux (in-cdr tree))))))))

      (aux tree))))

;
; Given a Kernel value, returns an immutable copy of its evaluation structure.
;
(define copy-es-immutable
  (make-es-copier
    mutable? kernel-car kernel-cdr
    (let ((name  (list #f)))
      (lambda (key)
        (let ((content  (cons () ())))
          (let ((immutable  (lambda (message)
                              (case message
                                ((type) 'immutable)
                                ((name) name)
                                ((kar)  (car content))
                                ((kdr)  (cdr content))))))
            (cons key
                  (cons immutable content))))))
    (let ((name  (list #f)))
      (lambda (kar kdr)
        (lambda (message)
          (case message
            ((type) 'immutable)
            ((name) name)
            ((kar)  kar)
            ((kdr)  kdr)))))
    (lambda (x) x)))

;
; Given a Kernel value, returns a mutable copy of its evaluation structure.
;
(define copy-es
  (make-es-copier
    kernel-pair? kernel-car kernel-cdr
    (lambda (key)
      (let ((content  (cons () ())))
        (cons key (cons content content))))
    cons
    (lambda (x) x)))

;
; Given a scheme value presumed to have just been read, returns a mutable
; Kernel version of the value, by copying its evaluation structure and
; transforming certain symbols to their Kernel counterparts.
;
(define scheme-read-object->kernel
  (make-es-copier
    pair? car cdr
    (lambda (key)
      (let ((content  (cons () ())))
        (cons key (cons content content))))
    kernel-cons
    (lambda (x)
      (if (symbol? x)
          (case x
            ((%ignore) ignore)
            ((%inert)  inert)
            ((%e+infinity)  exact-positive-infinity)
            ((%e-infinity)  exact-negative-infinity)
            ((%i+infinity)  inexact-positive-infinity)
            ((%i-infinity)  inexact-negative-infinity)
            (else      x))
          x))))

;
; Given a kernel-list, returns a list with the same elements in the same order.
; The result is guaranteed to be a list (acyclic and made up of pairs), but is
; not guaranteed to be distinct from the given kernel-list:  if mutables are
; represented by pairs, the result may be the given kernel-list.  Therefore,
; this tool should only be used if the resultant list certainly will not be
; mutated (because mutating the result might mutate the original kernel-list).
;
; To guarantee that the result will be distinct from the argument,
; use  copy-kernel-list->list.
;
(define kernel-list->list
  (lambda (ls)
    (if (list? ls)
        ls
        (bounded-simple-map->list (car (get-list-metrics ls))
                                  (lambda (x) x)
                                  ls))))

;
; Given a list, returns a mutable kernel-list with the same elements in the
; same order.  The elements are assumed to be kernel values.  The result is
; not guaranteed to be distinct from the given list:  if mutables are
; represented by pairs, the result may be the given kernel-list.  Therefore,
; this tool should only be used if the given list won't be needed again
; (so that if it happens to be mutated, that won't be a problem).
;
(define list->kernel-list (lambda (x) x))

;
; Determines whether a tree (i.e., an arbitrary interpreted-language value)
; is cyclic.
;
(define cyclic-tree?
  (lambda (tree)

    (define aux
      (lambda (ancestors tree)
        (cond ((not (kernel-pair? tree))  #f)
              ((pair? (memq tree ancestors))  #t)
              (else
                (let ((ancestors  (cons tree ancestors)))
                  (or (aux ancestors (kernel-car tree))
                      (aux ancestors (kernel-cdr tree))))))))

    (aux () tree)))

;
; Given a tree of the interpreted language, output a representation of it to
; a given output-port, using a given procedure to output the non-object leaves.
; The latter takes as arguments the leaf and the output-port.  Either the third
; argument, or the second and third arguments, may be omitted.  If the third
; argument is omitted, write is used.  If the second argument is also omitted,
; the current output-port is used.
;
; Cyclicity is handled by keeping an alist of revisits (kernel-pairs that will
; be visited more than once and are to be expanded only on the first visit),
; where the cadr of each record is the position of the record in the alist,
; and the cddr of the record is #t or #f depending on whether that revisit has
; already been expanded once.
;
(define write-tree
  (lambda (x . options)
    (let ((outport     (if (pair? options)
                           (car options)
                           (current-output-port)))
          (write-leaf  (if (and (pair? options) (pair? (cdr options)))
                           (cadr options)
                           write))
          (table  (letrec ((aux  (lambda (ls k)
                                   (if (null? ls)
                                       ls
                                       (cons (cons (car ls) (cons k #f))
                                             (aux (cdr ls) (+ k 1)))))))
                    (aux (get-kernel-revisits x) 0))))

      (define write-visit
        (lambda (x rec)
          (display "#"        outport)
          (display (cadr rec) outport)
          (if (cddr rec)
              (display "#" outport)
              (begin
                (set-cdr! (cdr rec) #t)
                (display   "=(" outport)
                (write-car (kernel-car x))
                (write-cdr (kernel-cdr x))
                (display   ")" outport)))))

      (define write-cdr
        (lambda (x)
          (cond ((null? x))
                ((kernel-pair? x)
                   (let ((rec  (assq x table)))
                     (if (pair? rec)
                         (begin
                           (display     " . " outport)
                           (write-visit x rec))
                         (begin
                           (display   " " outport)
                           (write-car (kernel-car x))
                           (write-cdr (kernel-cdr x))))))
                (else
                   (display   " . " outport)
                   (write-car x)))))

      (define write-car
        (lambda (x)
          (cond ((kernel-pair? x)
                   (let ((rec  (assq x table)))
                     (if (pair? rec)
                         (write-visit x rec)
                         (begin
                           (display   "(" outport)
                           (write-car (kernel-car x))
                           (write-cdr (kernel-cdr x))
                           (display   ")" outport)))))
                ((object? x)  (display (describe-object x) outport))
                (else  (write-leaf x outport)))))

      (write-car x))))

;
; As write-tree, except that there must be exactly two arguments, and the
; non-object leaf output procedure is display rather than write.
;
(define display-tree
  (lambda (x outport)
    (write-tree x outport display)))

;
; Creates bindings for this type in a given environment.
;
; This code should not use any internal knowledge of the kernel-pair type.
; It appears in this file, rather than in "subfiles/ground.scm", simply
; because it is logically associated with the kernel-pair type.
;
(define bind-kernel-pair-primitives!
  (lambda (env)
    (add-bindings! env

      'pair? (unary-predicate->applicative  kernel-pair?)

      'cons
      (naive->checked-applicative
        (lambda (operand-tree)
          (kernel-cons (kernel-car operand-tree)
                       (kernel-cadr operand-tree)))
        "cons"
        2 2)

      'copy-es-immutable
      (naive->checked-applicative
        (lambda (operand-tree)
          (copy-es-immutable (kernel-car operand-tree)))
        "copy-es-immutable"
        1 1)

      'copy-es
      (naive->checked-applicative
        (lambda (operand-tree)
          (copy-es (kernel-car operand-tree)))
        "copy-es"
        1 1)

      'set-car!
      (action->checked-applicative
        (lambda (operand-tree env context)
          (let ((x  (kernel-car operand-tree))
                (y  (kernel-cadr operand-tree)))
            (if (mutable? x)
                (kernel-set-car! x y)
                (error-pass (make-error-descriptor
                              (list "Operand #1 is immutable"
                                    " when calling primitive set-car!")
                              (list "Operand tree: " (list operand-tree)))
                            context)))
          inert)
        2 2 kernel-pair? any?)

      'set-cdr!
      (action->checked-applicative
        (lambda (operand-tree env context)
          (let ((x  (kernel-car operand-tree))
                (y  (kernel-cadr operand-tree)))
            (if (mutable? x)
                (kernel-set-cdr! x y)
                (error-pass (make-error-descriptor
                              (list "Operand #1 is immutable"
                                    " when calling primitive set-cdr!")
                              (list "Operand tree: " (list operand-tree)))
                            context)))
          inert)
        2 2 kernel-pair? any?)

      )))

A  => subfiles/kernel-pair.scm +496 -0
@@ 1,496 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 1)
             (list 0.1 1))
(set-revision-date 2009 9 1)

;;;;;;;;;
; pairs ;
;;;;;;;;;
;
; Pairs in the interpreted language ("Kernel") are a different data type from
; pairs in the meta-language (Scheme).  The interpreted-language type is
; called "kernel-pair".  Outside of this file, types pair and kernel-pair
; cannot be assumed to be identical, nor can they be assumed to be disjoint.
;
; The interpreted language has both mutable and immutable kernel-pairs.
; Their subtypes are called respectively "mutable" and "immutable".
; Private to this file, immutables are disjoint from pairs, while two
; different implementations are possible for mutables, one in which mutables
; are actually pairs (unbeknownst to the rest of the interpreter), the other
; in which they too are disjoint from pairs.
;
; When a procedure for kernel-pairs is cognate to one for pairs, it is named
; by adding prefix "kernel-" to the Scheme name:  kernel-cons, kernel-car,
; kernel-cdr, kernel-caar, etc.
;
; The only constructor of immutables is copy-es-immutable, which returns an
; immutable copy of a kernel-pair and all other kernel-pairs reachable from
; it without passing through any non-kernel-pair.  Consequently, it is not
; possible for an immutable to have a mutable as its kernel-car or kernel-cdr.
;
; Type kernel-list differs from type list both by using kernel-pairs instead of
; pairs, and by allowing cycles.  An "improper kernel-list" doesn't have to be
; null-terminated, therefore all Kernel values are improper kernel-lists.
; Similarly, every Kernel value is a kernel-tree; but Scheme trees aren't used
; in the interpreter, so kernel-trees are called simply "trees".
;
;
; Implementing mutables disjointly is more expensive than implementing
; immutables that way, because there is usually just one immutable copy of an
; algorithm, but during evaluation of that one copy, many mutable argument
; lists are constructed.  On the other hand, if mutables are represented by
; pairs, it is appallingly easy for code elsewhere in the interpreter to treat
; Kernel structures as if they were Scheme structures, without the bug being
; detected for a long time.  Both implementations have been provided, one in
; file "subfiles/kernel-pair-disjoint.scm" and the other in file
; "subfiles/kernel-pair-overlapping.scm"; the file loaded by the interpreter,
; called "subfiles/kernel-pair.scm", is a copy of one or the other version.
;
; This is the disjoint version of the type.  A mutable kernel-pair is an object
; with type 'mutable and attribute 'kar, 'kdr, and 'content, where 'content is
; a pair whose car and cdr are returned by 'kar and 'kdr.  An immutable
; kernel-pair is an object with type 'immutable and attributes 'kar and 'kdr.
;

(define mutable? (make-object-type-predicate 'mutable))

(define immutable? (make-object-type-predicate 'immutable))

(define kernel-pair?
  (lambda (x)
    (or (mutable? x)
        (immutable? x))))

(define kernel-car
  (lambda (x)
    (x 'kar)))

(define kernel-cdr
  (lambda (x)
    (x 'kdr)))

(define kernel-caar (lambda (x) (kernel-car (kernel-car x))))
(define kernel-cadr (lambda (x) (kernel-car (kernel-cdr x))))
(define kernel-cddr (lambda (x) (kernel-cdr (kernel-cdr x))))
(define kernel-caddr (lambda (x) (kernel-car (kernel-cdr (kernel-cdr x)))))
(define kernel-cadddr
  (lambda (x) (kernel-car (kernel-cdr (kernel-cdr (kernel-cdr x))))))

(define kernel-cons
  (lambda (kar kdr)
    (let ((name     (list #t))
          (content  (cons kar kdr)))
      (lambda (message)
        (case message
          ((type)    'mutable)
          ((name)    name)
          ((kar)     (car content))
          ((kdr)     (cdr content))
          ((content) content))))))

(define kernel-list
  (lambda x
    (if (pair? x)
        (kernel-cons (car x) (apply kernel-list (cdr x)))
        x)))

(define kernel-set-car!
  (lambda (kernel-pair kar)
    (set-car! (kernel-pair 'content) kar)))

(define kernel-set-cdr!
  (lambda (kernel-pair kdr)
    (set-cdr! (kernel-pair 'content) kdr)))

;
; Constructs a procedure that takes as its sole argument a possibly-cyclic
; structure composed from some pair-like primitive data type, and returns a
; list of nodes of the structure (i.e., pair-like entities) whose revisits
; should be pruned during traversal of the structure.
;
; The precise condition that should be satisfied by the result is that the
; listed revisits are a minimal set sufficient to minimize a traversal of the
; structure.
;   "Sufficient to minimize a traversal" means that, if the structure were
; traversed, checking each node against the revisits-list; and at the first
; position where a listed node is visited, traversal would continue past it to
; its descendants, but at other positions where it occurs, traversal would not
; continue past it; then this traversal would visit every node of the
; structure at least once, and would revisit only nodes on the revisits-list.
;   "Minimal set" means that if any member of the revisits-list were removed,
; then it would no longer have this property, i.e., it would no longer be
; sufficient to minimize a traversal.
;
; The purpose of this condition is to all clients to preserve structural
; isomorphism.  This is a strictly more difficult task than merely preventing
; infinite traversal of cyclic structures.  For example, commands
;   ($define! x (list 1 2 3))
;   (set-car! x (cdr x))
; would produce acyclic structure  (#1=(2 3) . #1#)  whose revisit-list would
; be a singleton list of node #1#.  Merely to prevent infinite traversals,
; it would suffice to check each node against its ancestors; but that would
; not detect the redundancy in this example, so that any structural
; transformation based on such an algorithm could not be expected to produce
; a structurally isomorphic result.
;
; Arguments:
;   tree               --- the structure itself, composed of pair-like nodes
;   node?              --- predicate for the pair-like type
;   node-car, node-cdr --- accessors for the pair-like type
;
(define make-get-revisits
  (lambda (node? node-car node-cdr)

    (define aux
      (lambda (revisits all . trees)
        (if (null? trees)
            revisits
            (let ((tree   (car trees))
                  (trees  (cdr trees)))
              (cond ((or (not (node? tree))
                         (pair? (memq tree revisits)))
                       (apply aux revisits all trees))
                    ((pair? (memq tree all))
                       (apply aux (cons tree revisits) all trees))
                    (else
                       (apply aux revisits (cons tree all)
                                  (node-car tree) (node-cdr tree) trees)))))))

    ; get-revisits
    (lambda (tree)
      (aux () () tree))))

(define get-kernel-revisits
  (make-get-revisits kernel-pair? kernel-car kernel-cdr))

;
; Constructs a procedure that takes as its sole argument a possibly-cyclic
; structure composed from some pair-like primitive data type, and returns
; a structurally isomorphic copy of its evaluation structure, optionally
; performing some transformation on leaf nodes during the copy.
;
; There will be three such procedures constructed:
; copy-es-immutable, copy-es, and scheme-read-object->kernel.
;
; The evaluation structure of a value (under a given pair-like primitive type)
; is the structure whose start is the value itself, and whose members are all
; objects reachable from the start by following only car and cdr references
; (of the given pair-like primitive type).  If the value is not of the
; chosen pair-like type, then the value itself is the only object of the
; data structure.
;
; Arguments:
;     in-pair?       --- predicate for the input pair-like type
;     in-car, in-cdr --- accessors for the input pair-like type
;     make-record    --- constructs an alist record (see below)
;     out-cons       --- constructs a copy of a non-pruned parent node
;     xform-leaf     --- transformation to perform on leaves when copying
;
; First, compiles an alist whose keys are those in-pairs in the input
; structure whose cyclic revisiting must be pruned during traversal.  For
; each of these in-pairs, make-record constructs an alist record whose key
; is the in-pair, whose cadr is an out-pair, and whose cddr is a pair whose
; elements determine the out-car and out-cdr of the out-pair.  (Depending on
; representations, the cadr and cddr might actually be the same object.)  Then
; the in-pairs of the input structure are traversed a second time, creating
; out-pairs for non-pruned mutables using out-cons, and setting the elements
; of the previously constructed out-pairs for pruned in-pairs.  When the
; elements of a pruned out-pair are to be set, its content pair is separated
; out and the cddr of its record is set to nil, to prevent infinite recursion.
;
(define make-es-copier
  (lambda (in-pair? in-car in-cdr make-record out-cons xform-leaf)

    (define get-in-revisits (make-get-revisits in-pair? in-car in-cdr))

    ; es-copier
    (lambda (tree)

      (define alist (map make-record (get-in-revisits tree)))

      (define aux
        (lambda (tree)
          (if (not (in-pair? tree))
              (xform-leaf tree)
              (let ((record  (assq tree alist)))
                (if (pair? record)
                    (let ((content  (cddr record)))
                      (if (pair? content)
                          (begin
                            (set-cdr! (cdr record) ())
                            (set-car! content (aux (in-car tree)))
                            (set-cdr! content (aux (in-cdr tree)))))
                      (cadr record))
                    (out-cons (aux (in-car tree))
                              (aux (in-cdr tree))))))))

      (aux tree))))

;
; Given a Kernel value, returns an immutable copy of its evaluation structure.
;
(define copy-es-immutable
  (make-es-copier
    mutable? kernel-car kernel-cdr
    (let ((name  (list #f)))
      (lambda (key)
        (let ((content  (cons () ())))
          (let ((immutable  (lambda (message)
                              (case message
                                ((type) 'immutable)
                                ((name) name)
                                ((kar)  (car content))
                                ((kdr)  (cdr content))))))
            (cons key
                  (cons immutable content))))))
    (let ((name  (list #f)))
      (lambda (kar kdr)
        (lambda (message)
          (case message
            ((type) 'immutable)
            ((name) name)
            ((kar)  kar)
            ((kdr)  kdr)))))
    (lambda (x) x)))

;
; Given a Kernel value, returns a mutable copy of its evaluation structure.
;
(define copy-es
  (make-es-copier
    kernel-pair? kernel-car kernel-cdr
    (lambda (key)
      (let* ((kernel-pair  (kernel-cons () ()))
             (content      (kernel-pair 'content)))
        (cons key (cons kernel-pair content))))
    kernel-cons
    (lambda (x) x)))

;
; Given a scheme value presumed to have just been read, returns a mutable
; Kernel version of the value, by copying its evaluation structure and
; transforming certain symbols to their Kernel counterparts.
;
(define scheme-read-object->kernel
  (make-es-copier
    pair? car cdr
    (lambda (key)
      (let* ((kernel-pair  (kernel-cons () ()))
             (content      (kernel-pair 'content)))
        (cons key (cons kernel-pair content))))
    kernel-cons
    (lambda (x)
      (if (symbol? x)
          (case x
            ((%ignore) ignore)
            ((%inert)  inert)
            ((%e+infinity)  exact-positive-infinity)
            ((%e-infinity)  exact-negative-infinity)
            ((%i+infinity)  inexact-positive-infinity)
            ((%i-infinity)  inexact-negative-infinity)
            (else      x))
          x))))

;
; Given a kernel-list, returns a list with the same elements in the same order.
; The result is guaranteed to be a list (acyclic and made up of pairs), but is
; not guaranteed to be distinct from the given kernel-list:  if mutables are
; represented by pairs, the result may be the given kernel-list.  Therefore,
; this tool should only be used if the resultant list certainly will not be
; mutated (because mutating the result might mutate the original kernel-list).
;
; To guarantee that the result will be distinct from the argument,
; use  copy-kernel-list->list.
;
(define kernel-list->list
  (lambda (ls)
    (copy-kernel-list->list ls)))

;
; Given a list, returns a mutable kernel-list with the same elements in the
; same order.  The elements are assumed to be kernel values.  The result is
; not guaranteed to be distinct from the given list:  if mutables are
; represented by pairs, the result may be the given kernel-list.  Therefore,
; this tool should only be used if the given list won't be needed again
; (so that if it happens to be mutated, that won't be a problem).
;
(define list->kernel-list
  (lambda (ls)
    (if (null? ls)
        ls
        (kernel-cons (car ls)
                     (list->kernel-list (cdr ls))))))

;
; Determines whether a tree (i.e., an arbitrary interpreted-language value)
; is cyclic.
;
(define cyclic-tree?
  (lambda (tree)

    (define aux
      (lambda (ancestors tree)
        (cond ((not (kernel-pair? tree))  #f)
              ((pair? (memq tree ancestors))  #t)
              (else
                (let ((ancestors  (cons tree ancestors)))
                  (or (aux ancestors (kernel-car tree))
                      (aux ancestors (kernel-cdr tree))))))))

    (aux () tree)))

;
; Given a tree of the interpreted language, output a representation of it to
; a given output-port, using a given procedure to output the non-object leaves.
; The latter takes as arguments the leaf and the output-port.  Either the third
; argument, or the second and third arguments, may be omitted.  If the third
; argument is omitted, write is used.  If the second argument is also omitted,
; the current output-port is used.
;
; Cyclicity is handled by keeping an alist of revisits (kernel-pairs that will
; be visited more than once and are to be expanded only on the first visit),
; where the cadr of each record is the position of the record in the alist,
; and the cddr of the record is #t or #f depending on whether that revisit has
; already been expanded once.
;
(define write-tree
  (lambda (x . options)
    (let ((outport     (if (pair? options)
                           (car options)
                           (current-output-port)))
          (write-leaf  (if (and (pair? options) (pair? (cdr options)))
                           (cadr options)
                           write))
          (table  (letrec ((aux  (lambda (ls k)
                                   (if (null? ls)
                                       ls
                                       (cons (cons (car ls) (cons k #f))
                                             (aux (cdr ls) (+ k 1)))))))
                    (aux (get-kernel-revisits x) 0))))

      (define write-visit
        (lambda (x rec)
          (display "#"        outport)
          (display (cadr rec) outport)
          (if (cddr rec)
              (display "#" outport)
              (begin
                (set-cdr! (cdr rec) #t)
                (display   "=(" outport)
                (write-car (kernel-car x))
                (write-cdr (kernel-cdr x))
                (display   ")" outport)))))

      (define write-cdr
        (lambda (x)
          (cond ((null? x))
                ((kernel-pair? x)
                   (let ((rec  (assq x table)))
                     (if (pair? rec)
                         (begin
                           (display     " . " outport)
                           (write-visit x rec))
                         (begin
                           (display   " " outport)
                           (write-car (kernel-car x))
                           (write-cdr (kernel-cdr x))))))
                (else
                   (display   " . " outport)
                   (write-car x)))))

      (define write-car
        (lambda (x)
          (cond ((kernel-pair? x)
                   (let ((rec  (assq x table)))
                     (if (pair? rec)
                         (write-visit x rec)
                         (begin
                           (display   "(" outport)
                           (write-car (kernel-car x))
                           (write-cdr (kernel-cdr x))
                           (display   ")" outport)))))
                ((object? x)  (display (describe-object x) outport))
                ((pair? x)
                   (display "#[misplaced meta-language structure: ")
                   (write x)
                   (display "]"))
                (else  (write-leaf x outport)))))

      (write-car x))))

;
; As write-tree, except that there must be exactly two arguments, and the
; non-object leaf output procedure is display rather than write.
;
(define display-tree
  (lambda (x outport)
    (write-tree x outport display)))

;
; Creates bindings for this type in a given environment.
;
; This code should not use any internal knowledge of the kernel-pair type.
; It appears in this file, rather than in "subfiles/ground.scm", simply
; because it is logically associated with the kernel-pair type.
;
(define bind-kernel-pair-primitives!
  (lambda (env)
    (add-bindings! env

      'pair? (unary-predicate->applicative  kernel-pair?)

      'cons
      (naive->checked-applicative
        (lambda (operand-tree)
          (kernel-cons (kernel-car operand-tree)
                       (kernel-cadr operand-tree)))
        "cons"
        2 2)

      'copy-es-immutable
      (naive->checked-applicative
        (lambda (operand-tree)
          (copy-es-immutable (kernel-car operand-tree)))
        "copy-es-immutable"
        1 1)

      'copy-es
      (naive->checked-applicative
        (lambda (operand-tree)
          (copy-es (kernel-car operand-tree)))
        "copy-es"
        1 1)

      'set-car!
      (action->checked-applicative
        (lambda (operand-tree env context)
          (let ((x  (kernel-car operand-tree))
                (y  (kernel-cadr operand-tree)))
            (if (mutable? x)
                (kernel-set-car! x y)
                (error-pass (make-error-descriptor
                              (list "Operand #1 is immutable"
                                    " when calling primitive set-car!")
                              (list "Operand tree: " (list operand-tree)))
                            context)))
          inert)
        2 2 kernel-pair? any?)

      'set-cdr!
      (action->checked-applicative
        (lambda (operand-tree env context)
          (let ((x  (kernel-car operand-tree))
                (y  (kernel-cadr operand-tree)))
            (if (mutable? x)
                (kernel-set-cdr! x y)
                (error-pass (make-error-descriptor
                              (list "Operand #1 is immutable"
                                    " when calling primitive set-cdr!")
                              (list "Operand tree: " (list operand-tree)))
                            context)))
          inert)
        2 2 kernel-pair? any?)

      )))

A  => subfiles/keyed.scm +154 -0
@@ 1,154 @@
; This file is part of SINK, a Scheme-based Interpreter for Not-quite Kernel
; Copyright (c) 2009 John N. Shutt

(set-version (list 0.0 1)
             (list 0.1 1))
(set-revision-date 2009 8 31)

;;;;;;;;;;;;;;;;;;;
; keyed variables ;
;;;;;;;;;;;;;;;;;;;
;
; Keyed variables are (from the Kernel programmer's perspective) bound and
; accessed via matched sets of combiners --- one binder and one accessor for
; each "variable".  There are two kinds of keyed variables:  dynamic keyed
; variables, which are bound in contexts, and static keyed variables, which are
; bound in environments (but are entirely separate from symbolic variables).
; Internally, each context or environment holds a list of key/value pairs; the
; holding object regulates access to the alist, but the actual operations
; are handled by tools provided here --- key assignment, alist construction,
; and lookup.
;
; The keys are integers.  Once an alist is in a context/environment, it is
; never mutated.
;
; There is no need for the alists or the keys to be encapsulated, because the
; purpose of encapsulation is to prevent Kernel programs from violating
; abstraction barriers on the objects they manipulate, and Kernel programs
; are never allowed to directly touch the alists or keys.
;

;
; Assigns a fresh key.
;
(define get-fresh-key
  (let ((counter  0))
    (lambda ()
      (set! counter (+ counter 1))
      counter)))

;
; Given an alist and a key and value, constructs a new alist whose only
; difference from the given alist is a binding of given key to given value.
;
; Allocates only as many new pairs as necessary to guarantee that the new alist
; has only one binding for the given key (assuming that the given alist didn't
; already have more than one binding for it).
;
(define make-alist
  (lambda (alist key value)

    (define aux       ; assumes the key is bound somewhere in alist
      (lambda (alist)
        (if (eq? (caar alist) key)
            (cons (cons key value) (cdr alist))
            (cons (car alist) (aux (cdr alist))))))

    (if (and (pair? alist)
             (pair? (assq key alist)))
        (aux alist)
        (cons (cons key value) alist))))

;
; Given zero or more alists, constructs a single alist containing the first
; binding for each key among the given alists.
;
(define merge-alists
  (lambda lss

    (define aux2
      (lambda (alist1 alist2)
        (if (null? alist1)
            alist2
            (make-alist (aux2 (cdr alist1) alist2)
                        (caar alist1)
                        (cdar alist1)))))

    (define aux
      (lambda (alist . lss)
        (if (null? lss)
            alist
            (aux2 alist (apply aux lss)))))

    (if (null? lss)
        lss
        (apply aux lss))))

;
; Looks up a key in an alist.
;
(define alist-lookup assq)

;
; Constructs a top-level dynamic alist.
;
; This must happen when the interpreter is called, not when the interpreter is
; constructed, because the top-level input-port and output-port should be those
; in effect when the interpreter is called, not when it is constructed.  The
; bindings are provided by procedures in other files, which are called from
; here, and which in turn are responsible for calling get-fresh-key.  The other
; procedures return alists.
;

(define make-top-level-dynamic-alist
  (lambda ()
     (make-top-level-ports-alist)))

;
; Creates bindings for keyed variables in a given environment.
;
(define bind-keyed-variable-primitives!
  (lambda (env)
    (add-bindings! env

      'make-keyed-dynamic-variable
      (naive->checked-applicative
        (lambda (operand-tree)
          (let ((key  (get-fresh-key)))
            (list
              (action->checked-applicative
                (lambda (operand-list env context)
                  (call-with-keyed-context
                    (lambda (context)
                      (eval (kernel-cdr operand-list) env context))
                    context
                    key
                    (kernel-car operand-list)))
                2 2 any? combiner?)
              (action->checked-applicative
                (lambda (operand-list env context)
                  (context-keyed-lookup key context))
                0 0))))
        "make-keyed-dynamic-variable"
        0 0)

      'make-keyed-static-variable
      (naive->checked-applicative
        (lambda (operand-tree)
          (let ((key  (get-fresh-key)))
            (list
              (action->checked-applicative
                (lambda (operand-list env context)
                  (make-environment-with-keyed-binding
                    key
                    (kernel-car operand-list)
                    (kernel-cadr operand-list)))
                2 2 any? environment?)
              (action->checked-applicative
                (lambda (operand-list env context)
                  (environment-keyed-lookup key env context))
                0 0))))
        "make-keyed-static-variable"
        0 0)

      )))

A  => subfiles/library.snk +718 -0
@@ 1,718 @@
;
; version number and date
;
($set-version (0.0 3)
              (0.1 2))
($set-revision-date 2009 8 30)

;
; derived core features
;   derivations are as in the R-1RK, not chosen for efficiency
;

($define! $sequence
   ((wrap ($vau ($seq2) %ignore
             ($seq2
                ($define! $aux
                   ($vau (head . tail) env
                      ($if (null? tail)
                           (eval head env)
                           ($seq2
                              (eval head env)
                              (eval (cons $aux tail) env)))))
                ($vau body env
                   ($if (null? body)
                        %inert
                        (eval (cons $aux body) env))))))

      ($vau (first second) env
         ((wrap ($vau %ignore %ignore (eval second env)))
          (eval first env)))))

($define! list (wrap ($vau x %ignore x)))

($define! list*
   (wrap ($vau args %ignore
            ($sequence
               ($define! aux
                  (wrap ($vau ((head . tail)) %ignore
                           ($if (null? tail)
                                head
                                (cons head (aux tail))))))
               (aux args)))))

($define! $vau
   ((wrap ($vau ($vau) %ignore
             ($vau (formals eformal . body) env
                (eval (list $vau formals eformal
                           (cons $sequence body))
                      env))))
      $vau))

($define! $lambda
   ($vau (formals . body) env
      (wrap (eval (list* $vau formals %ignore body)
                  env))))

($define! car ($lambda ((x . %ignore)) x))
($define! cdr ($lambda ((%ignore . x)) x))

($define! caar ($lambda (((x . %ignore) . %ignore)) x))
($define! cdar ($lambda (((%ignore . x) . %ignore)) x))
($define! cadr ($lambda ((%ignore . (x . %ignore))) x))
($define! cddr ($lambda ((%ignore . (%ignore . x))) x))

($define! caaar ($lambda ((((x . %ignore) . %ignore) . %ignore)) x))
($define! cdaar ($lambda ((((%ignore . x) . %ignore) . %ignore)) x))
($define! cadar ($lambda (((%ignore . (x . %ignore)) . %ignore)) x))
($define! cddar ($lambda (((%ignore . (%ignore . x)) . %ignore)) x))
($define! caadr ($lambda ((%ignore . ((x . %ignore) . %ignore))) x))
($define! cdadr ($lambda ((%ignore . ((%ignore . x) . %ignore))) x))
($define! caddr ($lambda ((%ignore . (%ignore . (x . %ignore)))) x))
($define! cdddr ($lambda ((%ignore . (%ignore . (%ignore . x)))) x))

($define! caaaar ($lambda (((((x . %ignore) . %ignore) . %ignore). %ignore))x))
($define! cdaaar ($lambda (((((%ignore . x) . %ignore) . %ignore). %ignore))x))
($define! cadaar ($lambda ((((%ignore . (x . %ignore)) . %ignore). %ignore))x))
($define! cddaar ($lambda ((((%ignore . (%ignore . x)) . %ignore). %ignore))x))
($define! caadar ($lambda (((%ignore . ((x . %ignore) . %ignore)). %ignore))x))
($define! cdadar ($lambda (((%ignore . ((%ignore . x) . %ignore)). %ignore))x))
($define! caddar ($lambda (((%ignore . (%ignore . (x . %ignore))). %ignore))x))
($define! cdddar ($lambda (((%ignore . (%ignore . (%ignore . x))). %ignore))x))
($define! caaadr ($lambda ((%ignore .(((x . %ignore) . %ignore) . %ignore)))x))
($define! cdaadr ($lambda ((%ignore .(((%ignore . x) . %ignore) . %ignore)))x))
($define! cadadr ($lambda ((%ignore .((%ignore . (x . %ignore)) . %ignore)))x))
($define! cddadr ($lambda ((%ignore .((%ignore . (%ignore . x)) . %ignore)))x))
($define! caaddr ($lambda ((%ignore .(%ignore . ((x . %ignore) . %ignore))))x))
($define! cdaddr ($lambda ((%ignore .(%ignore . ((%ignore . x) . %ignore))))x))
($define! cadddr ($lambda ((%ignore .(%ignore . (%ignore . (x . %ignore)))))x))
($define! cddddr ($lambda ((%ignore .(%ignore . (%ignore . (%ignore . x)))))x))

($define! apply
   ($lambda (appv arg . opt)
      (eval (cons (unwrap appv) arg)
            ($if (null? opt)
                 (make-environment)
                 (car opt)))))

($define! $cond
   ($vau clauses env

      ($define! aux
         ($lambda ((test . body) . clauses)
            ($if (eval test env)
                 (apply (wrap $sequence) body env)
                 (apply (wrap $cond) clauses env))))

      ($if (null? clauses)
           %inert
           (apply aux clauses))))

($define! get-list-metrics
   ($lambda (ls)

      ($define! aux
         ($lambda (kth k nth n)
            ($if (>=? k n)
                 ($if (pair? (cdr nth))
                      (aux ls 0 (cdr nth) (+ n 1))
                      (list (+ n 1)
                            ($if (null? (cdr nth)) 1 0)
                            (+ n 1)
                            0))
                 ($if (eq? kth nth)
                      (list n 0 k (- n k))
                      (aux (cdr kth) (+ k 1) nth n)))))

      ($if (pair? ls)
           (aux ls 0 ls 0)
           (list 0 ($if (null? ls) 1 0) 0 0))))

($define! list-tail
   ($lambda (ls k)
      ($if (>? k 0)
           (list-tail (cdr ls) (- k 1))
           ls)))

($define! encycle!
   ($lambda (ls k1 k2)
      ($if (>? k2 0)
           (set-cdr! (list-tail ls (+ k1 k2 -1))
                     (list-tail ls k1))
           %inert)))

;
; digression:
;   math applicatives max and lcm are used by map, so must be provided
;   to test map, and without using anything derived later than map
;

($define! max
   ($lambda x

      ($define! aux
         ($lambda (count result . x)
            ($if (<=? count 0)
                 result
                 ($sequence
                    ($if (>? (car x) result)
                         ($define! result ($if (inexact? result)
                                               (* (car x) 1.0)
                                               (car x)))
                         ($if (inexact? (car x))
                              ($define! result (* result 1.0))
                              %inert))
                    (apply aux (list* (- count 1) result (cdr x)))))))

      (apply aux (list* (car (get-list-metrics x))
                        %e-infinity
                        x))))

($define! lcm
   ($lambda x

      ($define! gcd
         ($lambda (x y)
            ($if (=? x y)
                 x             ; don't worry here about inexactness
                 ($if (<? x y)
                      (gcd x (- y x))
                      (gcd (- x y) y)))))

      ($define! aux3
         ($lambda (x y)
            (/ (* x y) (gcd x y))))

      ($define! aux2
         ($lambda (result k)
            ($cond ((=? k 0)                 (* k %e+infinity)) ; induce error
                   ((=? k %e+infinity)       (* k result))
                   ((=? k %e-infinity)       (* k result -1))
                   ((=? result %e+infinity)  (* result (abs k)))
                   (#t                       (aux3 result (abs k))))))

      ($define! aux
         ($lambda (count result . x)
            ($if (<=? count 0)
                 result
                 (apply aux (list* (- count 1)
                                   (aux2 result (car x))
                                   (cdr x))))))

      (apply aux (list* (car (get-list-metrics x))
                        1
                        x))))

;
; now, back to core derivations
;

($define! map
   (wrap ($vau (appv . lss) env

      ($define! acc
         ($lambda (input (k1 k2) base-result head tail sum)
            ($define! aux
               ($lambda (input count)
                  ($if (=? count 0)
                       base-result
                       (sum (head input)
                            (aux (tail input) (- count 1))))))
            (aux input (+ k1 k2))))

      ($define! enlist
         ($lambda (input ms head tail)
            ($define! result (acc input ms () head tail cons))
            (apply encycle! (list* result ms))
            result))

      ($define! mss (cddr (get-list-metrics lss)))

      ($define! cars ($lambda (lss) (enlist lss mss caar cdr)))
      ($define! cdrs ($lambda (lss) (enlist lss mss cdar cdr)))

      ($define! result-metrics
         (acc lss mss (cddr (get-list-metrics (car lss)))
              ($lambda (lss) (cddr (get-list-metrics (car lss))))
              cdr
              ($lambda ((j1 j2) (k1 k2))
                 (list (max j1 k1)
                       ($cond ((=? j2 0)  k2)
                              ((=? k2 0)  j2)
                              (#t  (lcm j2 k2)))))))

      (enlist lss
              result-metrics
              ($lambda (lss) (apply appv (cars lss) env))
              cdrs))))

($define! $let
   ($vau (bindings . body) env
      (eval (cons (list* $lambda (map car bindings) body)
                  (map cadr bindings))
            env)))

($define! not? ($lambda (x) ($if x #f #t)))

($define! and?
   ($lambda x

      ($define! aux
         ($lambda (x k)
            ($cond ((<=? k 0)  #t)
                   ((car x)    (aux (cdr x) (- k 1)))
                   (#t         #f))))

      (aux x (car (get-list-metrics x)))))

($define! or?
   ($lambda x
      (not? (apply and? (map not? x)))))

($define! $and?
   ($vau x e
      ($cond ((null? x)         #t)
             ((null? (cdr x))   (eval (car x) e)) ; tail context
             ((eval (car x) e)  (apply (wrap $and?) (cdr x) e))
             (#t                #f))))

($define! $or?
   ($vau x e
      ($cond ((null? x)         #f)
             ((null? (cdr x))   (eval (car x) e)) ; tail context
             ((eval (car x) e)  #t)
             (#t                (apply (wrap $or?) (cdr x) e)))))

($define! combiner?
   ($lambda x
      (apply and? (map ($lambda (x)
                          (or? (applicative? x)
                               (operative? x)))
                       x))))

($define! length
   ($lambda (object)
      ($let (((%ignore %ignore a c)  (get-list-metrics object)))
         ($if (>? c 0)
              %e+infinity
              a))))

($define! list-ref
   ($lambda (ls k)
      (car (list-tail ls k))))

($define! append
   ($lambda lss

      ($define! set-last!
         ($lambda (ls tail) ; set cdr of last pair of ls to tail
            ($let ((next  (cdr ls)))
               ($if (pair? next)
                    (set-last! next tail)
                    (set-cdr! ls tail)))))

      ($define! aux2
         ($lambda (ls tail) ; prepend ls onto tail
            ($if (null? ls)
                 tail
                 (cons (car ls) (aux2 (cdr ls) tail)))))