mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-04-17 07:30:43 -07:00
Code Issues Projects Releases Packages Wiki Activity

Initial revision

Browse source
This commit is contained in:
jjgarcia 2001-06-26 17:14:44 +00:00
commit 2d8d0cd44b
1434 changed files with 443893 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

69
Copyright Normal file
View file

@ -0,0 +1,69 @@
_______________________________________________________________________________
Copyright (c) 2000, Juan Jose Garcia Ripoll
Copyright (c) 1990, 1991, 1993 Giuseppe Attardi
Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
All Rights Reserved
_______________________________________________________________________________
Summary:
Permission is granted to use, copy, modify this program,
EXCEPT that the copyright notice must be reproduced on copies, and
credit should be given to the authors where it is due.
WE MAKE NO WARRANTY AND ACCEPT NO LIABILITY FOR THIS PROGRAM.
In detail:
1. Permission to use, copy, modify this software and its documentation
for any purpose is hereby granted without fee, provided that
- the above copyright notice appears in all copies,
- both that copyright notice and this permission notice appears in
supporting documentation, and that
- you cause modified files to carry prominent notices stating that
you changed the files and the date of any change.
2. Please notify us if you are going to sell this software or its
documentation for profit.
3. WE DISCLAIM ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL
WE BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR
ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS,
WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION,
ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
SOFTWARE.
Additionally:
ECLS 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; see file 'Copying'.
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.
Address:
Juan Jose Garcia Ripoll
Univ. de Castilla-La Mancha
E.T.S.I. Industriales
Departamento de Matematicas
c/Camilo Jose Cela, 3
Ciudad Real, E-13071
Spain
Address for reporting bugs, comments, suggestions:
jjgarcia@ind-cr.uclm.es

481
LGPL Normal file
View file

@ -0,0 +1,481 @@
GNU LIBRARY GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 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.
[This is the first released version of the library GPL. It is
numbered 2 because it goes with version 2 of the ordinary GPL.]
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
Licenses are intended to guarantee your freedom to share and change
free software--to make sure the software is free for all its users.
This license, the Library General Public License, applies to some
specially designated Free Software Foundation software, and to any
other libraries whose authors decide to use it. You can use it for
your libraries, 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 library, or if you modify it.
For example, if you distribute copies of the library, whether gratis
or for a fee, you must give the recipients all the rights that we gave
you. You must make sure that they, too, receive or can get the source
code. If you link a program with the library, you must provide
complete object files to the recipients so that they can relink them
with the library, after making changes to the library and recompiling
it. And you must show them these terms so they know their rights.
Our method of protecting your rights has two steps: (1) copyright
the library, and (2) offer you this license which gives you legal
permission to copy, distribute and/or modify the library.
Also, for each distributor's protection, we want to make certain
that everyone understands that there is no warranty for this free
library. If the library is modified by someone else and passed on, we
want its recipients to know that what they have is not the original
version, 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 companies distributing free
software will individually obtain patent licenses, thus in effect
transforming the program into proprietary software. To prevent this,
we have made it clear that any patent must be licensed for everyone's
free use or not licensed at all.
Most GNU software, including some libraries, is covered by the ordinary
GNU General Public License, which was designed for utility programs. This
license, the GNU Library General Public License, applies to certain
designated libraries. This license is quite different from the ordinary
one; be sure to read it in full, and don't assume that anything in it is
the same as in the ordinary license.
The reason we have a separate public license for some libraries is that
they blur the distinction we usually make between modifying or adding to a
program and simply using it. Linking a program with a library, without
changing the library, is in some sense simply using the library, and is
analogous to running a utility program or application program. However, in
a textual and legal sense, the linked executable is a combined work, a
derivative of the original library, and the ordinary General Public License
treats it as such.
Because of this blurred distinction, using the ordinary General
Public License for libraries did not effectively promote software
sharing, because most developers did not use the libraries. We
concluded that weaker conditions might promote sharing better.
However, unrestricted linking of non-free programs would deprive the
users of those programs of all benefit from the free status of the
libraries themselves. This Library General Public License is intended to
permit developers of non-free programs to use free libraries, while
preserving your freedom as a user of such programs to change the free
libraries that are incorporated in them. (We have not seen how to achieve
this as regards changes in header files, but we have achieved it as regards
changes in the actual functions of the Library.) The hope is that this
will lead to faster development of free libraries.
The precise terms and conditions for copying, distribution and
modification follow. Pay close attention to the difference between a
"work based on the library" and a "work that uses the library". The
former contains code derived from the library, while the latter only
works together with the library.
Note that it is possible for a library to be covered by the ordinary
General Public License rather than by this special one.
GNU LIBRARY GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License Agreement applies to any software library which
contains a notice placed by the copyright holder or other authorized
party saying it may be distributed under the terms of this Library
General Public License (also called "this License"). Each licensee is
addressed as "you".
A "library" means a collection of software functions and/or data
prepared so as to be conveniently linked with application programs
(which use some of those functions and data) to form executables.
The "Library", below, refers to any such software library or work
which has been distributed under these terms. A "work based on the
Library" means either the Library or any derivative work under
copyright law: that is to say, a work containing the Library or a
portion of it, either verbatim or with modifications and/or translated
straightforwardly into another language. (Hereinafter, translation is
included without limitation in the term "modification".)
"Source code" for a work means the preferred form of the work for
making modifications to it. For a library, 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 library.
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running a program using the Library is not restricted, and output from
such a program is covered only if its contents constitute a work based
on the Library (independent of the use of the Library in a tool for
writing it). Whether that is true depends on what the Library does
and what the program that uses the Library does.
1. You may copy and distribute verbatim copies of the Library's
complete 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 distribute a copy of this License along with the
Library.
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 Library or any portion
of it, thus forming a work based on the Library, 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) The modified work must itself be a software library.
b) You must cause the files modified to carry prominent notices
stating that you changed the files and the date of any change.
c) You must cause the whole of the work to be licensed at no
charge to all third parties under the terms of this License.
d) If a facility in the modified Library refers to a function or a
table of data to be supplied by an application program that uses
the facility, other than as an argument passed when the facility
is invoked, then you must make a good faith effort to ensure that,
in the event an application does not supply such function or
table, the facility still operates, and performs whatever part of
its purpose remains meaningful.
(For example, a function in a library to compute square roots has
a purpose that is entirely well-defined independent of the
application. Therefore, Subsection 2d requires that any
application-supplied function or table used by this function must
be optional: if the application does not supply it, the square
root function must still compute square roots.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Library,
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 Library, 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 Library.
In addition, mere aggregation of another work not based on the Library
with the Library (or with a work based on the Library) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may opt to apply the terms of the ordinary GNU General Public
License instead of this License to a given copy of the Library. To do
this, you must alter all the notices that refer to this License, so
that they refer to the ordinary GNU General Public License, version 2,
instead of to this License. (If a newer version than version 2 of the
ordinary GNU General Public License has appeared, then you can specify
that version instead if you wish.) Do not make any other change in
these notices.
Once this change is made in a given copy, it is irreversible for
that copy, so the ordinary GNU General Public License applies to all
subsequent copies and derivative works made from that copy.
This option is useful when you wish to copy part of the code of
the Library into a program that is not a library.
4. You may copy and distribute the Library (or a portion or
derivative of it, under Section 2) in object code or executable form
under the terms of Sections 1 and 2 above provided that you 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.
If distribution of 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 satisfies the requirement to
distribute the source code, even though third parties are not
compelled to copy the source along with the object code.
5. A program that contains no derivative of any portion of the
Library, but is designed to work with the Library by being compiled or
linked with it, is called a "work that uses the Library". Such a
work, in isolation, is not a derivative work of the Library, and
therefore falls outside the scope of this License.
However, linking a "work that uses the Library" with the Library
creates an executable that is a derivative of the Library (because it
contains portions of the Library), rather than a "work that uses the
library". The executable is therefore covered by this License.
Section 6 states terms for distribution of such executables.
When a "work that uses the Library" uses material from a header file
that is part of the Library, the object code for the work may be a
derivative work of the Library even though the source code is not.
Whether this is true is especially significant if the work can be
linked without the Library, or if the work is itself a library. The
threshold for this to be true is not precisely defined by law.
If such an object file uses only numerical parameters, data
structure layouts and accessors, and small macros and small inline
functions (ten lines or less in length), then the use of the object
file is unrestricted, regardless of whether it is legally a derivative
work. (Executables containing this object code plus portions of the
Library will still fall under Section 6.)
Otherwise, if the work is a derivative of the Library, you may
distribute the object code for the work under the terms of Section 6.
Any executables containing that work also fall under Section 6,
whether or not they are linked directly with the Library itself.
6. As an exception to the Sections above, you may also compile or
link a "work that uses the Library" with the Library to produce a
work containing portions of the Library, and distribute that work
under terms of your choice, provided that the terms permit
modification of the work for the customer's own use and reverse
engineering for debugging such modifications.
You must give prominent notice with each copy of the work that the
Library is used in it and that the Library and its use are covered by
this License. You must supply a copy of this License. If the work
during execution displays copyright notices, you must include the
copyright notice for the Library among them, as well as a reference
directing the user to the copy of this License. Also, you must do one
of these things:
a) Accompany the work with the complete corresponding
machine-readable source code for the Library including whatever
changes were used in the work (which must be distributed under
Sections 1 and 2 above); and, if the work is an executable linked
with the Library, with the complete machine-readable "work that
uses the Library", as object code and/or source code, so that the
user can modify the Library and then relink to produce a modified
executable containing the modified Library. (It is understood
that the user who changes the contents of definitions files in the
Library will not necessarily be able to recompile the application
to use the modified definitions.)
b) Accompany the work with a written offer, valid for at
least three years, to give the same user the materials
specified in Subsection 6a, above, for a charge no more
than the cost of performing this distribution.
c) If distribution of the work is made by offering access to copy
from a designated place, offer equivalent access to copy the above
specified materials from the same place.
d) Verify that the user has already received a copy of these
materials or that you have already sent this user a copy.
For an executable, the required form of the "work that uses the
Library" must include any data and utility programs needed for
reproducing the executable from it. 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.
It may happen that this requirement contradicts the license
restrictions of other proprietary libraries that do not normally
accompany the operating system. Such a contradiction means you cannot
use both them and the Library together in an executable that you
distribute.
7. You may place library facilities that are a work based on the
Library side-by-side in a single library together with other library
facilities not covered by this License, and distribute such a combined
library, provided that the separate distribution of the work based on
the Library and of the other library facilities is otherwise
permitted, and provided that you do these two things:
a) Accompany the combined library with a copy of the same work
based on the Library, uncombined with any other library
facilities. This must be distributed under the terms of the
Sections above.
b) Give prominent notice with the combined library of the fact
that part of it is a work based on the Library, and explaining
where to find the accompanying uncombined form of the same work.
8. You may not copy, modify, sublicense, link with, or distribute
the Library except as expressly provided under this License. Any
attempt otherwise to copy, modify, sublicense, link with, or
distribute the Library 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.
9. 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 Library or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Library (or any work based on the
Library), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Library or works based on it.
10. Each time you redistribute the Library (or any work based on the
Library), the recipient automatically receives a license from the
original licensor to copy, distribute, link with or modify the Library
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.
11. 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 Library at all. For example, if a patent
license would not permit royalty-free redistribution of the Library 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 Library.
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.
12. If the distribution and/or use of the Library is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Library 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.
13. The Free Software Foundation may publish revised and/or new
versions of the Library 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 Library
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 Library does not specify a
license version number, you may choose any version ever published by
the Free Software Foundation.
14. If you wish to incorporate parts of the Library into other free
programs whose distribution conditions are incompatible with these,
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
15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO
WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW.
EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR
OTHER PARTIES PROVIDE THE LIBRARY "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
LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME
THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION.
16. 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 LIBRARY 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
LIBRARY (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 LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), 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 Libraries
If you develop a new library, and you want it to be of the greatest
possible use to the public, we recommend making it free software that
everyone can redistribute and change. You can do so by permitting
redistribution under these terms (or, alternatively, under the terms of the
ordinary General Public License).
To apply these terms, attach the following notices to the library. 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 library's name and a brief idea of what it does.>
Copyright (C) <year> <name of author>
This library 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 library 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 library; 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.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the library, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the
library `Frob' (a library for tweaking knobs) written by James Random Hacker.
<signature of Ty Coon>, 1 April 1990
Ty Coon, President of Vice
That's all there is to it!

166
Makefile Normal file
View file

@ -0,0 +1,166 @@
# Generated automatically from Makefile.in by configure.
# DIST: This is the distribution Makefile for ECL. configure can
# DIST: make most of the changes to this file you might want, so try
# DIST: that first.
# make all to compile and build Emacs.
# make install to install it.
# make TAGS to update tags tables.
#
# make clean or make mostlyclean
# Delete all files from the current directory that are normally
# created by building the program. Don't delete the files that
# record the configuration. Also preserve files that could be made
# by building, but normally aren't because the distribution comes
# with them.
#
# Delete `.dvi' files here if they are not part of the distribution.
#
# make distclean
# Delete all files from the current directory that are created by
# configuring or building the program. If you have unpacked the
# source and built the program without creating any other files,
# `make distclean' should leave only the files that were in the
# distribution.
#
# make realclean
# Delete everything from the current directory that can be
# reconstructed with this Makefile. This typically includes
# everything deleted by distclean.
SHELL = /bin/sh
MAKE = make # BSD doesn't have it as a default.
MACHINE = freebsd
# ========================= Last release ================================
VERSION=0.2
WWW=http://ecls.sourceforge.net/
# ==================== Things `configure' Might Edit ====================
CC=gcc
CPP=gcc -E
LN_S=ln -s
CFLAGS=-g -O2
# Where to find the source code.
# This is set by the configure script's `--srcdir' option.
srcdir=/home/jjgarcia/ecl/src
bindir=/home/jjgarcia/bin
infodir=/home/jjgarcia/info
mandir=/home/jjgarcia/man/man1
libdir=/home/jjgarcia/lib/ecls
# What to release
TAR_CONTENTS=Makefile.in Copy* README.1st README.orig doc \
configure site.lsp src/c src/cmp src/crs src/clos src/lsp src/doc \
src/h src/etc src/gmp src/config* src/install.sh src/Makefile.in \
src/util contrib/ src/clx src/tk src/gc src/*.in src/gabriel
# ==================== Utility Programs for the Build ====================
# Allow the user to specify the install program.
INSTALL = /usr/bin/install -c
INSTALL_PROGRAM = ${INSTALL}
INSTALL_DATA = ${INSTALL} -m 644
# ============================= Build ==============================
all: build/Makefile
cd build; $(MAKE)
.PHONY: all
Makefile: Makefile.in build/config.status
(cd build; ./config.status)
# ==================== Installation ====================
install: build/Makefile
(cd build; make install)
uninstall:
(cd build; make uninstall)
# ==================== Documentation ====================
info:
(cd ${srcdir}/doc; $(MAKE) info)
dvi:
(cd ${srcdir}/doc; $(MAKE) dvi)
# ==================== Cleaning up and miscellanea ====================
# `clean'
# Delete all files from the current directory that are normally
# created by building the program. Don't delete the files that
# record the configuration. Also preserve files that could be made
# by building, but normally aren't because the distribution comes
# with them.
#
clean:
cd build; $(MAKE) clean
# `distclean'
# Delete all files from the current directory that are created by
# configuring or building the program. If you have unpacked the
# source and built the program without creating any other files,
# `make distclean' should leave only the files that were in the
# distribution.
distclean: clean
rm -fr build/config.status
rm -f Makefile
# `realclean'
# Delete everything from the current directory that can be
# reconstructed with this Makefile.
# One exception, however: `make realclean' should not delete
# `configure' even if `configure' can be remade using a rule in the
# Makefile. More generally, `make realclean' should not delete
# anything that needs to exist in order to run `configure' and then
# begin to build the program.
realclean: distclean
TAGS tags:
(cd ${srcdir}/src; \
etags c/*.[cd] h/*.h)
check:
@echo "We don't have any tests for ECL yet."
TAR_DIR=ecls-$(VERSION)
doc: build/doc/index.html
-mkdir doc
cp build/doc/*.html doc
build/doc/index.html:
cd build/doc; make
source-dist: ecls.tgz ecls-tests.tgz
ecls.tgz: doc
-rm -rf $(TAR_DIR)
mkdir $(TAR_DIR) $(TAR_DIR)/src && \
for i in $(TAR_CONTENTS); do cp -rf $$i $(TAR_DIR)/$$i; done && \
tar -cz --exclude '*~' --exclude '#*' --exclude 'CVS' -f ecls.tgz $(TAR_DIR)
-rm -rf $(TAR_DIR)
ecls-tests.tgz:
-rm -rf $(TAR_DIR)
mkdir $(TAR_DIR) && \
mkdir $(TAR_DIR)/src && \
cp -rf src/ansi-tests $(TAR_DIR)/src && \
tar -cz --exclude '*~' --exclude '#*' --exclude 'CVS' -f ecls-tests.tgz $(TAR_DIR);
-rm -rf $(TAR_DIR)
binary-dist: all
su -c "rm -rf tmp"
mkdir tmp
for i in $(bindir) $(infodir) $(mandir) $(libdir); do \
(echo $$i; IFS="/"; for k in tmp/$$i; do echo $$k; (test -d $$k || mkdir $$k); chmod 755 $$k; cd $$k; done); \
done
PREFIX=`pwd`/tmp; cd build; make install PREFIX="$${PREFIX}"
su -c "chown -R root.root tmp && cd tmp; tar czf ../ecls-$(VERSION)-$(MACHINE).tgz * && cd .. && rm -rf tmp"
dist:
cd dist; make-dist

165
Makefile.in Normal file
View file

@ -0,0 +1,165 @@
# DIST: This is the distribution Makefile for ECL. configure can
# DIST: make most of the changes to this file you might want, so try
# DIST: that first.
# make all to compile and build Emacs.
# make install to install it.
# make TAGS to update tags tables.
#
# make clean or make mostlyclean
# Delete all files from the current directory that are normally
# created by building the program. Don't delete the files that
# record the configuration. Also preserve files that could be made
# by building, but normally aren't because the distribution comes
# with them.
#
# Delete `.dvi' files here if they are not part of the distribution.
#
# make distclean
# Delete all files from the current directory that are created by
# configuring or building the program. If you have unpacked the
# source and built the program without creating any other files,
# `make distclean' should leave only the files that were in the
# distribution.
#
# make realclean
# Delete everything from the current directory that can be
# reconstructed with this Makefile. This typically includes
# everything deleted by distclean.
SHELL = /bin/sh
MAKE = make # BSD doesn't have it as a default.
MACHINE = @MACHINE@
# ========================= Last release ================================
VERSION=@ECLS_VERSION@
WWW=http://ecls.sourceforge.net/
# ==================== Things `configure' Might Edit ====================
CC=@CC@
CPP=@CPP@
LN_S=@LN_S@
CFLAGS=@CFLAGS@
# Where to find the source code.
# This is set by the configure script's `--srcdir' option.
srcdir=@srcdir@
bindir=@bindir@
infodir=@infodir@
mandir=@mandir@
libdir=@libdir@
# What to release
TAR_CONTENTS=Makefile.in Copy* README.1st README.orig doc \
configure site.lsp src/c src/cmp src/crs src/clos src/lsp src/doc \
src/h src/etc src/gmp src/config* src/install.sh src/Makefile.in \
src/util contrib/ src/clx src/tk src/gc src/*.in src/gabriel
# ==================== Utility Programs for the Build ====================
# Allow the user to specify the install program.
INSTALL = @INSTALL@
INSTALL_PROGRAM = @INSTALL_PROGRAM@
INSTALL_DATA = @INSTALL_DATA@
# ============================= Build ==============================
all: build/Makefile
cd build; $(MAKE)
.PHONY: all
Makefile: Makefile.in build/config.status
(cd build; ./config.status)
# ==================== Installation ====================
install: build/Makefile
(cd build; make install)
uninstall:
(cd build; make uninstall)
# ==================== Documentation ====================
info:
(cd ${srcdir}/doc; $(MAKE) info)
dvi:
(cd ${srcdir}/doc; $(MAKE) dvi)
# ==================== Cleaning up and miscellanea ====================
# `clean'
# Delete all files from the current directory that are normally
# created by building the program. Don't delete the files that
# record the configuration. Also preserve files that could be made
# by building, but normally aren't because the distribution comes
# with them.
#
clean:
cd build; $(MAKE) clean
# `distclean'
# Delete all files from the current directory that are created by
# configuring or building the program. If you have unpacked the
# source and built the program without creating any other files,
# `make distclean' should leave only the files that were in the
# distribution.
distclean: clean
rm -fr build/config.status
rm -f Makefile
# `realclean'
# Delete everything from the current directory that can be
# reconstructed with this Makefile.
# One exception, however: `make realclean' should not delete
# `configure' even if `configure' can be remade using a rule in the
# Makefile. More generally, `make realclean' should not delete
# anything that needs to exist in order to run `configure' and then
# begin to build the program.
realclean: distclean
TAGS tags:
(cd ${srcdir}/src; \
etags c/*.[cd] h/*.h)
check:
@echo "We don't have any tests for ECL yet."
TAR_DIR=ecls-$(VERSION)
doc: build/doc/index.html
-mkdir doc
cp build/doc/*.html doc
build/doc/index.html:
cd build/doc; make
source-dist: ecls.tgz ecls-tests.tgz
ecls.tgz: doc
-rm -rf $(TAR_DIR)
mkdir $(TAR_DIR) $(TAR_DIR)/src && \
for i in $(TAR_CONTENTS); do cp -rf $$i $(TAR_DIR)/$$i; done && \
tar -cz --exclude '*~' --exclude '#*' --exclude 'CVS' -f ecls.tgz $(TAR_DIR)
-rm -rf $(TAR_DIR)
ecls-tests.tgz:
-rm -rf $(TAR_DIR)
mkdir $(TAR_DIR) && \
mkdir $(TAR_DIR)/src && \
cp -rf src/ansi-tests $(TAR_DIR)/src && \
tar -cz --exclude '*~' --exclude '#*' --exclude 'CVS' -f ecls-tests.tgz $(TAR_DIR);
-rm -rf $(TAR_DIR)
binary-dist: all
su -c "rm -rf tmp"
mkdir tmp
for i in $(bindir) $(infodir) $(mandir) $(libdir); do \
(echo $$i; IFS="/"; for k in tmp/$$i; do echo $$k; (test -d $$k || mkdir $$k); chmod 755 $$k; cd $$k; done); \
done
PREFIX=`pwd`/tmp; cd build; make install PREFIX="$${PREFIX}"
su -c "chown -R root.root tmp && cd tmp; tar czf ../ecls-$(VERSION)-$(MACHINE).tgz * && cd .. && rm -rf tmp"
dist:
cd dist; make-dist

1
README.1st Normal file
View file

@ -0,0 +1 @@
You can find the preprocessed documentation in ./doc in HTML format.

20
configure vendored Executable file
View file

@ -0,0 +1,20 @@
#!/bin/sh
#
# This is just a driver for configure, the real configure is in src.
# This script identifies the machine, and creates a directory for
# the installation, where it runs ${srcdir}/configure.
srcdir=`pwd`/src
buildir=build
if [ ! -d ${buildir} ] ; then
echo Creating directory "\`${buildir}'"
mkdir ${buildir}
fi
# Now run the real configure script
echo Switching to directory "\`${buildir}'" to continue configuration.
cd ${buildir}
${srcdir}/configure --srcdir=${srcdir} $*
echo Configuration complete. To build ECL, issue 'make' in this directory.

1951
contrib/logical-pathnames.ecl Normal file
View file

File diff suppressed because it is too large Load diff

2000
contrib/logical-pathnames.lsp Normal file
View file

File diff suppressed because it is too large Load diff

2730
contrib/make.lsp Normal file
View file

File diff suppressed because it is too large Load diff

347
contrib/metering.lsp Normal file
View file

@ -0,0 +1,347 @@
From daemon Fri Jul 8 22:43:26 1994
>From clisp-list@ma2s2.mathematik.uni-karlsruhe.de Fri Jul 8 22:43:16 1994
Return-Path: <clisp-list@ma2s2.mathematik.uni-karlsruhe.de>
Date: Fri, 8 Jul 94 22:45:40 +0200
Errors-To: haible@ma2s2.mathematik.uni-karlsruhe.de
Originator: clisp-list@ma2s2.mathematik.uni-karlsruhe.de
Errors-To: haible@ma2s2.mathematik.uni-karlsruhe.de
Reply-To: clisp-list <clisp-list@ma2s2.mathematik.uni-karlsruhe.de>
Sender: clisp-list@ma2s2.mathematik.uni-karlsruhe.de
Version: 5.5 -- Copyright (c) 1991/92, Anastasios Kotsikonas
From: donc@ISI.EDU (Don Cohen)
To: Multiple recipients of list <clisp-list@ma2s2.mathematik.uni-karlsruhe.de>
Subject: recording function calls
From: "Edward G. Kovach" <kovach@franus.edu>
Is there a way to ... get a listing of..
A. How many times a particular function is called?
B. How much time it takes to run each function?
I've seen several such facilities. The one I like, though, is
my own, included below. At the cost of some extra space, it
records not only the number of calls and total time, but each
individual call, its inputs and outputs, its start/finish time.
This is much more useful for debugging and tuning, since you get
to see WHICH calls took a lot of time, which ones got the wrong
inputs or computed the wrong results, etc.
;;; -*- Mode: LISP; Package: USER; Syntax: Common-lisp -*-
(lisp::in-package "USER")
; ---- Record the calls to given functions ----
#| 2/17/89 - try to avoid advice, not so much because it's not commonlisp
as because it's not compiled! In fact, I want to be able to turn on and
off recording at high frequency and encapsulations seem to get in the way
of this. For now I'll assume that one does not encapsulate and record the
same functions.
In order to monitor a function one first prepares it for monitoring, then
one can turn monitoring on and off at high frequency. One can also reset
or read the monitoring data for a function. Finally one can forget about
monitoring a function.
*monitored-fns* is a list of functions currently prepared for monitoring.
(prepare-record-calls '(f1 f2 f3)) prepares the functions named.
additional keyword arguments: entryforms, exitforms, test
The entryforms are evaluated at function entry, the exitforms at function
exit. The results are recorded along with inputs, outputs, entry time
and exit time. Test is a form (default is T) that determines whether
this particular call will be recorded. It runs in an environment where
ARGS is bound to the argument list of the function.
(record-on '(f1 f2 f3)) turns on recording for these functions.
(record-off '(f1 f2 f3)) turns it off.
(initialize-records '(f1 f2 f3)) discards all monitoring data for the
functions (but does not turn recording off or on and does not forget
preparation).
(recorded-calls 'f1) returns a list of the call records for f1.
This is a list of records of the form
(inputs outputs start-time1 start-time2 end-time1 end-time2
<values of entry forms> <values of exit forms>)
Times are represented as 2 numbers since some clocks wrap around.
The second is a wrap around count that is incremented whenever the
finish time comes out lower than the start time.
(summarize-calls '(f1 f2 f3)) prints a summary of the calls.
The argument defaults to *monitored-fns*.
Additional optional argument: name-alist
Name-alist is something like ((f1 . "updating database") (f2 . "waiting"))
and is used to translate function names into something more meaningful.
(forget-record-calls '(f1 f2 f3)) discards all monitoring data and preparation
(longest-n-calls 'f2 3) lists the 3 longest recorded calls of f2
additional keyword arguments: start end filterfn
filterfn - a function of 1 arg (inputs outputs start finish)
should return T if the call is "interesting"
start/end are special cases - filter out anything that starts before start
or ends after end
(time-line '(f1 f2 f3) produces a time line of activity
additional keyword arguments: (width 80) filterfn start end name-alist
Both symbolics and TI have a fast short clock and a slow long one.
We use the fast one on symbolics, slow one on TI.
time before wrap around / #usec to read clock
--------------------------------------------
symbolics 3600 TI explorer II
fast >.5 hour / 67 * 16 sec. / 260
slow >100 yrs / 218 >1 hour / 260 *
Actually we notice wrap around and record it - whenever a clock access
returns a smaller value than the previous one we increment a counter.
Therefore all events are ordered correctly, but if you fail to read the
clock for an hour or so, it's as if that time never passed. This is bad
if you time things on such a coarse scale, but good if you time one thing
for a minute today and something else for a minute tomorrow - the time
line between such events never separates them by much more than an hour.
In practice I don't think this will matter much.
Since calls are recorded by pushing onto a list at exit, they are ordered
by decreasing exit time. This is handy for finding the outermost calls
in the case where the calls all come from the same process (and must thus
be properly nested).
(outermost (recorded-calls 'foo))
returns the subset of the calls to foo that are outermost.
|#
(defvar *monitored-fns* nil)
(defvar *clock-cycle* 0)
(defvar *last-time* 0)
(defun prepare-record-calls (fns &key entryforms exitforms (test t))
(loop for fn in fns do (prepare-record-call fn entryforms exitforms test)))
; record-calls-fn prop is cons substitute and original fns
(defun prepare-record-call (fn entryforms exitforms test &aux prop)
(cond ((not (fboundp fn)) (error "no such function as ~A" fn))
#+zetalisp
((and (si:function-encapsulated-p fn)
(warn "~A is an encapsulation") nil))
#+ignore ; might be called with different entryforms/exitforms
((and (setf prop (get fn 'record-calls-fn))
(eq (cdr prop) (symbol-function fn)))
#+ignore (warn "~A already recorded" fn))
((eq (symbol-function fn) (car prop))
#+ignore (warn "~A already prepared" fn))
(t ; not cached ...
(setf (get fn 'record-calls-fn)
(cons (make-record-fn fn entryforms exitforms test)
(symbol-function fn)))
(pushnew fn *monitored-fns*))))
(defun make-record-fn (fn entryforms exitforms test)
(compile nil
`(lambda (&rest args &aux start start1 values finish finish1 entryvals)
(if ,test
(unwind-protect
(progn (setq entryvals (list ,@entryforms)
start (microsec-time)
start1 *clock-cycle*
values (multiple-value-list
(apply ',(symbol-function fn) args))
finish (microsec-time) finish1 *clock-cycle*)
(values-list values))
(record-1-call ',fn (copy-list args)
(if finish values :abnormal-exit)
start start1
(or finish (microsec-time))
(or finish1 *clock-cycle*)
entryvals
(list ,@exitforms)))
(apply ',(symbol-function fn) args)))))
; perhaps we should try to correct for the time spent in the new function?
(defun forget-record-calls (fns)
(record-off fns)
(loop for fn in fns do
(setq *monitored-fns* (delete fn *monitored-fns*))
(setf (get fn 'record-calls-fn) nil)
(setf (get fn 'recorded-calls) nil)))
(defun record-on (fns)
(loop for fn in fns do
(let ((prop (get fn 'record-calls-fn)))
(cond ((not prop) (cerror "skip turning on recording"
"~A not prepared for recording" fn))
((eq (cdr prop) (symbol-function fn))
(setf (symbol-function fn) (car prop)))
((eq (car prop) (symbol-function fn)))
(t (cerror "skip turning on recording"
"~A has changed since last prepared for recording"
fn))))))
(defun record-off (fns)
(loop for fn in fns do
(let ((prop (get fn 'record-calls-fn)))
(cond ((not prop)
(cerror "continue" "~A not prepared for recording" fn))
((eq (car prop) (symbol-function fn))
(setf (symbol-function fn) (cdr prop)))
((eq (cdr prop) (symbol-function fn)))
(t (cerror "continue"
"~A has changed since recording last turned on"
fn))))))
(defun microsec-time (&aux time)
(setq time
#-(or symbolics ti) (get-internal-run-time)
#+symbolics (time:fixnum-microsecond-time)
#+TI (time:microsecond-time))
(when (< time *last-time*) (incf *clock-cycle*))
(setf *last-time* time))
(defun record-1-call (fn inputs results t1 t11 t2 t21 entryvals exitvals)
(push (list inputs results t1 t11 t2 t21 entryvals exitvals)
(get fn 'recorded-calls)))
(defun initialize-records (fns)
(loop for fn in fns do (setf (get fn 'recorded-calls) nil)))
(defun recorded-calls (fn) (get fn 'recorded-calls))
(defun summarize-calls (&optional (fns *monitored-fns*) name-alist)
(loop for fn in fns do
(summarize-record fn (get fn 'recorded-calls) name-alist)))
(defun summarize-record (fn calls name-alist)
(when calls (loop for x in calls sum 1 into ncalls
sum (elapsed (third x) (fourth x) (fifth x) (sixth x))
into time finally
(print-summarize-record fn ncalls time name-alist))))
(defun print-summarize-record (fn ncalls time name-alist)
(multiple-value-bind (total tunits)
(standardized-time-units time)
(multiple-value-bind (avg aunits)
(standardized-time-units (float (/ time ncalls)))
(format *standard-output* "~%~A: ~A calls, ~A ~A (avg. ~A~:[ ~a~; ~])"
(or (cdr (assoc fn name-alist)) fn)
ncalls total tunits avg (eq aunits tunits) aunits))))
(defun standardized-time-units (usec)
(cond ((> usec 999999) (values (float (/ usec 1000000)) "sec."))
((> usec 999) (values (float (/ usec 1000)) "msec."))
(t (values usec "usec."))))
(defun elapsed (t1 t11 t2 t21)
(+ (- t2 t1) (* (- t21 t11) (* 1024 1024 2048 #+TI 2))))
(defun longest-n-calls (fn n &key start end filterfn
&aux next time current
(candidates (recorded-calls fn)) (i 0))
; filterfn decides whether a record is "interesting"
; special cases: start/end filters out anything that starts before start
; or ends after end
(flet ((filter (e) (and (or (null start)
(plusp (elapsed start 0 (third e) (fourth e))))
(or (null end)
(plusp (elapsed (fifth e) (sixth e) end 0)))
(or (null filterfn) (funcall filterfn e)))))
(loop while (and (< i n) (setq next (pop candidates)))
when (filter next)
do (incf i) (push (cons (elapsed (third next) (fourth next)
(fifth next) (sixth next))
next) current))
(setq current (sort current #'<= :key #'car))
(loop while (setq next (pop candidates))
when (filter next)
when (< (caar current)
(setq time (elapsed (third next) (fourth next)
(fifth next) (sixth next))))
do (setq current (merge 'list (cdr current)
(list (cons time next))
#'<= :key #'car)))
(nreverse current)))
(defvar *time-line-key*
"Start time = ~A, End time = ~A, Width = ~A, ~
~& each column represents ~A ~A~
~& Key: ( = 1 entry, ) = 1 exit, * = more than one entry/exit~
~& if no entry/exit, a digit indicates number of active calls,~
~& blank indicates no change, + indicates >9 ~% ")
(defun time-line (fns &key (width 80) filterfn start end len name-alist
&aux events)
(flet ((filter (e) (and (or (null start)
(plusp (elapsed start 0 (third e) (fourth e))))
(or (null end)
(plusp (elapsed (fifth e) (sixth e) end 0)))
(or (null filterfn) (funcall filterfn e)))))
(setq events (loop for f in fns collect
(cons f (loop for e in (recorded-calls f)
when (filter e) collect e))))
(unless (and start end)
(loop for e in events do
(loop for r in (cdr e) do
(when (or (null start)
(minusp (elapsed start 0 (third r) (fourth r))))
(setq start (totalt (third r) (fourth r))))
(when (or (null end)
(minusp (elapsed (fifth r) (sixth r) end 0)))
(setq end (totalt (fifth r) (sixth r)))))))
(when (and start end) (setq len (- end start)))
(unless (and len (> len 0)) (return-from time-line "empty interval"))
(multiple-value-bind (number unit)
(when (and start end width)
(standardized-time-units (/ (- end start 0.0) width)))
(apply #'concatenate 'string
(format nil *time-line-key* start end width number unit)
(loop for f in events collect
(concatenate 'string
(let ((string (make-string width
:initial-element #\space))
index
(countstart
(make-array (list width)
:initial-element 0
:element-type 'integer))
(countend
(make-array (list width) :initial-element 0
:element-type 'integer)))
(loop for e in (cdr f) do
(setq index
(min (1- width)
(floor (* width (/ (- (totalt (third e)
(fourth e))
start)
len)))))
(incf (aref countstart index))
(setf (aref string index)
(if (char= #\space (aref string index))
#\( #\*))
(setq index
(min (1- width)
(floor (* width (/ (- (totalt (fifth e)
(sixth e))
start)
len)))))
(decf (aref countend index))
(setf (aref string index)
(if (char= #\space (aref string index))
#\) #\*)))
(loop for i below width with sum = 0 do
(setf sum (+ sum (aref countstart i)
(aref countend i)))
(when (and (/= i 0)
(/= (aref countstart (1- i)) 0)
(/= (aref countend (1- i)) 0)
(char= #\space (aref string i))
(> sum 0))
(setf (aref string i)
(if (> sum 9) #\+ (aref "0123456789" sum)))))
string)
(format nil " ~A~& "
(symbol-name (or (cdr (assoc (car f) name-alist))
(car f))))))))))
(defun outermost (calls &aux outer)
(loop for c in calls
unless (and outer (<= (totalt (third outer) (fourth outer))
(totalt (third c) (fourth c))
(totalt (fifth c) (sixth c))
(totalt (fifth outer) (sixth outer))))
collect (setf outer c)))
; get the time represented by the two numbers x (low order) and y (high order)
(defun totalt (x y) (elapsed 0 0 x y))

129
contrib/pvm/eclreader.lsp Normal file
View file

@ -0,0 +1,129 @@
;;;-*-Mode: LISP; Syntax: Common LISP; Base: 10-*-
;;;
;;; File = eclreader.lsp
;;; Definition of reader for ECoLISP.
;;;
;;; (c) 1994, I.D. Alexander-Craig, all rights reserved.
;;;
;;;
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; Definition of the basic reader that is needed by KCL. ;;;;
;;;; The following function should be called when loading the ;;;;
;;;; object reader for KCL. This is called the default reader ;;;;
;;;; for KCL. ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
(defparameter *default-reader* ())
(defparameter *default-reader-specs*
(list
(list 'NULL
LISP_NIL_TYPE
*
#'(lambda (rdr)
(declare (ignore rdr))
()))
(list T
LISP_T_TYPE
'*
#'(lambda (rdr)
(declare (ignore rdr))
t))
(list 'STANDARD-CHAR ;; CHARACTER
LISP_CHAR_TYPE
#'(lambda (obj rdr)
(declare (ignore rdr))
(C-obuffer-char obj))
#'(lambda (rdr)
(declare (ignore rdr))
(C-ibuffer-char)))
(list 'FIXNUM
LISP_INT_TYPE
#'(lambda (obj rdr)
(declare (ignore rdr))
(C-obuffer-int obj))
#'(lambda (rdr)
(declare (ignore rdr))
(C-ibuffer-int)))
(list 'BIGNUM
LISP_LONGINT_TYPE
#'(lambda (obj rdr)
(declare (ignore rdr))
(C-obuffer-longint obj))
#'(lambda (rdr)
(declare (ignore rdr))
(C-ibuffer-longint)))
(list 'LONG-FLOAT ;;FLOAT
LISP_DOUBLE_TYPE
#'(lambda (obj rdr)
(declare (ignore rdr))
(C-obuffer-double obj))
#'(lambda (rdr)
(declare (ignore rdr))
(C-ibuffer-double)))
(list 'SYMBOL
LISP_SYMBOL_TYPE
#'(lambda (obj rdr)
(declare (ignore rdr))
(cond ((eq obj t)
(C-obuffer-t))
((null obj)
(C-obuffer-nil))
(t
(let ((pname (symbol-name obj)))
(C-obuffer-symbol pname (length pname))))))
#'(lambda (rdr)
(declare (ignore rdr))
(C-ibuffer-symbol)))
(list 'STRING ;; SIMPLE-STRING
LISP_STRING_TYPE
#'(lambda (obj rdr)
(declare (ignore rdr))
(C-obuffer-string obj (length obj)))
#'(lambda (rdr)
(declare (ignore rdr))
(C-ibuffer-string)))
(list 'VECTOR
LISP_VECTOR_TYPE
#'(lambda (obj rdr)
(encode-vector obj rdr))
#'(lambda (rdr)
(decode-vector rdr)))
(list 'CONS
LISP_LIST_TYPE
#'(lambda (obj rdr)
(encode-list obj rdr))
#'(lambda (rdr)
(decode-list rdr)))))
;; For testing only:
(defparameter *rdr* ())
(defun init-default-reader ()
(setq *default-reader* (make-object-reader))
(initialise-reader-object
*default-reader*
*default-reader-specs*)
(values))
(format t "Creating reader:~%")
(init-default-reader)
(format t "Done.~%~%")
;;; For testing only:
(setq *rdr* *default-reader*)
(defun restart-reader ()
(setq *default-reader* ()
rdr ())
(init-default-reader)
(setq *rdr* *default-reader*)
(values))

2
contrib/pvm/hostfile Normal file
View file

@ -0,0 +1,2 @@
database
igor

11
contrib/pvm/load.lsp Normal file
View file

@ -0,0 +1,11 @@
;;;-*-Mode: LISP; Syntax: Common LISP; Base: 10-*-
;;;
;;; File = load.lsp
;;; Load file for ECL<->PVM interface modules.
;;;
(load "pvmconsts")
(load "pvmlisp")
(si:faslink "pvmecl" "-L/project/pvm/pvm3/lib/SUN4 -lgpvm3 -lpvm3 -lc")
;(load "pvmecl")
(load "eclreader")

14
contrib/pvm/pvm-test.lsp Normal file
View file

@ -0,0 +1,14 @@
(defparameter *my-tid* ())
(defun enroll ()
(setq *my-tid* (lpvm-my-tid)))
(defun leave ()
(lpvm-exit)
(quit))
(defun send-rec (msg msgtype)
(format t "about to send~%")
(lpvm-send-message msg *rdr* msgtype *my-tid*)
(format t "about to receive~%")
(lpvm-nonblocking-recv *rdr* *my-tid* msgtype))

109
contrib/pvm/pvmconsts.lsp Normal file
View file

@ -0,0 +1,109 @@
;;;-*- Mode: LISP; Syntax: Common LISP; Base: 10 -*-
;;;
;;; File = pvmconsts.lisp
;;;
;;; PVM constant definitions.
;;;
;;
;; Change log.
;; 25 March 1994. LISP_X_TYPE constants have contiguous values.
;; This is to support the new representation for the read structure.
;;
;;;
;;; Constant definitions for type tags used to define
;;; message boundaries.
;;; The tags are all ad hoc and tailored to the needs of LISP.
;;; Each is represented by an integer.
;;;
;;;
(defconstant MESSAGE_START 1)
;; This says that there is going to be
;; a new structure type that follows.
(defconstant LISP_NIL_TYPE 2) ; encode nil
(defconstant LISP_T_TYPE 3) ; encode t
(defconstant LISP_CHAR_TYPE 4)
(defconstant LISP_SHORTINT_TYPE 5)
(defconstant LISP_INT_TYPE 6)
(defconstant LISP_LONGINT_TYPE 7)
;(defconstant LISP_FLOAT_TYPE 8) not used in ECo or KCL
(defconstant LISP_DOUBLE_TYPE 9)
(defconstant LISP_SYMBOL_TYPE 10)
(defconstant LISP_STRING_TYPE 11)
(defconstant LISP_VECTOR_TYPE 12)
(defconstant LISP_LIST_TYPE 13)
;; If complex and rational are required, we can fit them in.
(defconstant LISP_OPAQUE_TYPE 14)
(defconstant LISP_MIN_USER_TYPE 15)
;;;
;;; PVM constant definitions for error messages, together
;;; with the error function for PVM routines.
;;;
(defconstant %PvmOk 0)
(defconstant %PvmBadParam -2)
(defconstant %PvmMismatch -3)
(defconstant %PvmNoData -5)
(defconstant %PvmNoHost -6)
(defconstant %PvmNoFile -7)
(defconstant %PvmNoMem -10)
(defconstant %PvmBadMsg -12)
(defconstant %PvmSysErr -14)
(defconstant %PvmNoBuf -15)
(defconstant %PvmNoSuchBuf -16)
(defconstant %PvmNullGroup -17)
(defconstant %PvmDupGroup -18)
(defconstant %PvmNoGroup -19)
(defconstant %PvmNotInGroup -20)
(defconstant %PvmNoInst -21)
(defconstant %PvmHostFail -22)
(defconstant %PvmNoParent -23)
(defconstant %PvmNotImpl -24)
(defconstant %PvmDSysErr -25)
(defconstant %PvmBadVersion -26)
(defconstant %PvmOutOfRes -27)
(defconstant %PvmDupHost -28)
(defconstant %PvmCantStart -29)
(defconstant %PvmAlready -30)
(defconstant %PvmNoTask -31)
(defconstant %PvmNoEntry -32)
(defconstant %PvmDupEntry -33)
(defun pvm-error (errno where)
;; quick hack for testing
(unless (= errno %PvmOk)
(error "PVM error in ~s no. ~d~%" where errno)))
;;;
;;; Constants for pvm_advise
;;;
(defconstant %PvmDontRoute 1)
(defconstant %PvmAllowDirect 2)
(defconstant %PvmRouteDirect 3)
;;;
;;; Constants for pvm_initsend's encoding
;;;
(defconstant %PvmDataDefault 0) ; use XDR if heterogeneous
(defconstant %PvmDataRaw 1) ; no encoding
(defconstant %PvmDataInPlace 2) ; leave data in place.
;;;
;;; Constants for pvm_spawn.
;;; See the PVM manual p. 13 for details.
;;;
(defconstant %PvmTaskDefault 0)
(defconstant %PvmTaskHost 1)
(defconstant %PvmTaskArch 2)
(defconstant %PvmTaskDebug 4)
(defconstant %PvmTaskTrace 8)

1058
contrib/pvm/pvmecl.c Normal file
View file

File diff suppressed because it is too large Load diff

756
contrib/pvm/pvmecl.lsp Normal file
View file

@ -0,0 +1,756 @@
;;;-*-Mode:LISP; Syntax: Common LISP; Base: 10-*-
;;;
;;; File = pvmecl.lsp
;;; Interface between ECoLISP and PVM.
;;; This file contains the C function interface between ECoLisp and PVM.
;;; It is not portable.
;;;
;;;
;;; (c) 1994, I.D. Alexander-Craig, all rights reserved.
;;;
;;;
;;;
;;; pvmconsts.lsp must be loaded before this file.
;;;
;;;
;;; Error function for PVM interface.
;;;
(defun pvm-error (errno routine)
(error "PVM interface error ~d in ~a~%" errno routine))
(clines "
#include \"/project/pvm/pvm3/include/pvm3.h\"
")
;;;
;;; Begin with buffering routines.
;;;
;;
;; Start with output buffering routines for simple types.
;; Each C function is followed by the corresponding entry
;; definition. Then comes the LISP function.
;;
(definline c_pvm_pkint (fixnum) fixnum
"({int x = #0; pvm_pkint(&x,1,1);})"
)
(defun obuffer-int (i)
(let ((info (c_pvm_pkint i)))
(unless (= %PvmOk info)
(pvm-error info "obuffer-int")))
(values))
;;
;; Packing routine for message types. This is a LISP function
;; that calls c_pvm_pkint to pack the type.
;;
(defun pack-type-tag (typetag)
(let ((return-code (c_pvm_pkint typetag)))
(unless (= %PvmOk return-code)
(pvm-error return-code "pack-type-tag")))
(values))
(defun C-obuffer-nil ()
(pack-type-tag LISP_NIL_TYPE))
(defun C-obuffer-t ()
(pack-type-tag LISP_T_TYPE))
(definline c_pvm_pkchar (character) fixnum
"({char x = #0; pvm_pkbyte(&x,1,1);})"
)
(defun C-obuffer-char (ch)
(pack-type-tag LISP_CHAR_TYPE)
(let ((info (c_pvm_pkchar ch)))
(unless (= %PvmOk info)
(pvm-error info "pvm_pkchar call")))
(values))
(defun C-obuffer-int (i)
(pack-type-tag LISP_INT_TYPE)
(let ((info (c_pvm_pkint i)))
(unless (= %PvmOk info)
(pvm-error info "pvm_pkint call")))
(values))
(definline c_pvm_pkfloat (short-float) fixnum
"({float x = #0; pvm_pkfloat(&x,1,1);})"
)
(defun obuffer-float (fl)
(let ((info (c_pvm_pkfloat fl)))
(unless (= %PvmOk info)
(pvm-error info "obuffer-float")))
(values))
(definline c_pvm_pkdouble (long-float) fixnum
"({double x = #0; pvm_pkdouble(&x,1,1);})"
)
(defun C-obuffer-double (db)
(let ((info (c_pvm_pkdouble db)))
(unless (= %PvmOk info)
(pvm-error info "obuffer-double")))
(values))
;;
;; Packing routines for symbol and string.
;; Both routines expect a string and a number (in that order)
;; to be supplied to them.
;; The number is the length of the string.
;;
;;
;; The first function packs the length and the string into
;; the output buffer.
;;
(definline c_pvm_pkstr (string fixnum) fixnum
"({int type = #1;
type = pvm_pkint(&type,1,1);
((type == PvmOk) ? pvm_pkstr((#0)->st.st_self) : type);})"
)
;;
;; Now define the routines that manipulate symbols and strings.
;;
(defun C-obuffer-symbol (s)
(let ((pname (symbol-name s)))
(let ((len (length pname)))
(pack-type-tag LISP_SYMBOL_TYPE)
(let ((info (c_pvm_pkstr pname len)))
(unless (= %PvmOk info)
(pvm-error info "obuffer-symbol")))))
(values))
(defun C-obuffer-string (str)
(let ((len (length str)))
(pack-type-tag LISP_STRING_TYPE)
(let ((info (c_pvm_pkstr str len)))
(unless (= %PvmOk info)
(pvm-error info "obuffer-string"))))
(values))
;;
;; Packing routines for vector and list headers.
;;
(defun C-obuffer-vector-header (vector-length)
(pack-type-tag LISP_VECTOR_TYPE)
(let ((info (c_pvm_pkint vector-length)))
(unless (= %PvmOk info)
(pvm-error info "obuffer-vector-header")))
(values))
(defun C-obuffer-list-header ()
(pack-type-tag LISP_LIST_TYPE)
(values))
;;
;; Unpacking routines for scalar types.
;;
(defcbody c_pvm_unpack_tag () object
" Cnil;
{ int tagval, info;
info = pvm_upkint(&tagval,1,1);
if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);}
VALUES(0) = MAKE_FIXNUM(info);
VALUES(1) = MAKE_FIXNUM(tagval);
RETURN(2);
}"
)
;(proclaim '(inline ibuffer-tag))
(defun ibuffer-tag ()
(multiple-value-bind (info value)
(c_pvm_unpack_int)
(if info
value
(pvm-error info "ibuffer-tag"))))
(defun C-next-msg-type ()
(ibuffer-tag))
(defun C-next-type-name ()
(ibuffer-tag))
(defcbody c_pvm_unpack_int () object
" Cnil;
{ int ival, info;
info = pvm_upkint(&ival,1,1);
if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);}
VALUES(0) = MAKE_FIXNUM(info);
VALUES(1) = MAKE_FIXNUM(ival);
RETURN(2);
}"
)
(defun C-ibuffer-int ()
(multiple-value-bind (info value)
(c_pvm_unpack_int)
(if info
value
(pvm-error info "ibuffer-int"))))
(defcbody c_pvm_unpack_char () object
" Cnil;
{ int info;
char chval;
info = pvm_upkbyte(&chval,1,1);
if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);}
VALUES(0) = MAKE_FIXNUM(info);
VALUES(1) = code_char(chval);
RETURN(2);
}"
)
(defun C-ibuffer-char ()
(multiple-value-bind (info value)
(c_pvm_unpack_char)
(if info
value
(pvm-error info "ibuffer-char"))))
(defcbody c_pvm_unpack_float () object
" Cnil;
{ int info;
float fval;
info = pvm_upkfloat(&fval,1,1);
if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);}
VALUES(0) = MAKE_FIXNUM(info);
VALUES(1) = make_shortfloat(fval);
RETURN(2);
}"
)
(defun ibuffer-float ()
(multiple-value-bind (info value)
(c_pvm_unpack_float)
(if info
value
(pvm-error info "ibuffer-float"))))
(defcbody c_pvm_unpack_double () object
" Cnil;
{
int info;
double dval;
info = pvm_upkdouble(&dval,1,1);
if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);}
VALUES(0) = MAKE_FIXNUM(info);
VALUES(1) = make_longfloat(dval);
RETURN(2);
}"
)
(defun C-ibuffer-double ()
(multiple-value-bind (info value)
(c_pvm_unpack_double)
(if info
value
(pvm-error info "ibuffer-double"))))
;;
;; Routines to get symbols and strings from the PVM
;; buffer.
;; This is a little tricky!
;;
;;
;; First, a general unpacking routine for strings.
;;
(defun setstring (chr indx str)
(setf (aref str indx) chr)
(values))
(defcbody c_pvm_unpack_chars (fixnum) object
"
Cnil;
{ char *strchrs;
int info;
info = pvm_upkstr(strchrs);
if (info != PvmOk) { VALUES(0) = Cnil; RETURN(1);}
VALUES(0) = MAKE_FIXNUM(info);
VALUES(1) = make_simple_string(strchrs);
RETURN(2);
}"
)
;;
;; Now the routine which gets the length and the string
;; from the buffer.
;;
(defun get-length-and-string ()
(let ((len (ibuffer-int)))
(multiple-value-bind (info str)
(c_pvm_unpack_chars len)
(if info
(if (= (length str) len)
str
(format
t
"received string has length ~a, not ~a as promised.~%"
(length str)
len))
(pvm-error info "get-length-and-string")))))
(defun C-ibuffer-symbol ()
; It might be useful sometimes just to return the string.
(let ((pname (get-length-and-string)))
(make-symbol pname)))
(defun C-ibuffer-string ()
(get-length-and-string))
(defun C-ibufer-vector-length ()
(C-ibuffer-int))
;;;
;;; Send and received routines (together with registration and exit).
;;;
(definline c_pvm_initsend (fixnum) fixnum
"pvm_initsend(#0)")
(defun lpvm-init-send (encoding)
(cond ((not (integerp encoding))
(error "lpvm-init-send expects an int, not a ~a~%"
(type-of encoding)))
((minusp encoding)
(error
"lpvm-init-send: encoding must be non-negative (~d)~%"
encoding))
(t
(let ((bufid (c_pvm_initsend encoding)))
(when (minusp bufid)
(pvm-error bufid "pvm_initsend call"))
bufid))))
(definline c_pvm_send (fixnum fixnum) fixnum
"pvm_send(#0, #1)")
;;;
;;; The send routine.
;;;
(defun lpvm-send-message (lisp-object
reader-object
message-type
destination-task
&optional (encoding %PvmDataDefault))
(lpvm-init-send encoding)
(write-object lisp-object reader-object)
(let ((info (c_pvm_send destination-task message-type)))
(when (minusp info)
(pvm-error info "pvm_send call")))
(values))
;;;
;;; The multi-cast routine is similar, but we set up the buffer
;;; once and then repeatedly send the message.
;;;
(defun lpvm-multicast (lisp-object
reader-object
message-type
destination-tasks
&optional (encoding %PvmDataDefault))
(lpvm-init-send encoding)
(write-object lisp-object reader-object)
(dolist (tid destination-tasks)
(let ((info (c_pvm_send tid message-type)))
(when (minusp info)
(pvm-error info "pvm_multicast"))))
(values))
;;;
;;; Receive routines.
;;;
(definline c_pvm_nrecv (fixnum fixnum) fixnum
"pvm_nrecv(#0,#1)"
)
(defun lpvm-nonblocking-recv (object-reader tid msgtag)
(let ((bufid (c_pvm_nrecv tid msgtag)))
(cond ((minusp bufid)
(pvm-error bufid "pvm_nrecv"))
((= %PvmOk bufid)
()) ; nothing there
((plusp bufid)
(read-object object-reader))
(t
(error
"something weird has happened---nonblocking-recv")))))
(definline c_pvm_recv (fixnum fixnum) fixnum
"pvm_recv(#0, #1)"
)
(defun lpvm-blocking-read (object-reader tid msgtag)
(let ((bufid (c_pvm_recv tid msgtag)))
(when (minusp bufid)
(pvm-error bufid "pvm_recv"))
(read-object object-reader)))
;;;
;;; Join PVM primitive.
;;;
(definline c_pvm_mytid () fixnum
"pvm_mytid()"
)
(defun lpvm-my-tid ()
(let ((info (c_pvm_mytid)))
(when (minusp info)
(pvm-error info "pvm_mytid call"))
info))
;;;
;;; Leave PVM primitive.
;;;
(definline c_pvm_exit () fixnum
"pvm_exit()")
(defun lpvm-exit ()
(let ((info (c_pvm_exit)))
(unless (= %PvmOk info)
(pvm-error info "pvm_exit call")))
(values))
(definline c_pvm_kill (fixnum) fixnum
"pvm_kill(#0)"
)
(defun lpvm-kill (tid)
(let ((info (c_pvm_kill tid)))
(when (minusp info)
(pvm-error info "pvm_kill call")))
(values))
(definline c_pvm_parent () fixnum
"pvm_parent()"
)
(defun lpvm-parent ()
(let ((info (c_pvm_parent)))
(when (= info %PvmNoParent)
(pvm-error info "pvm_parent")))
(values))
(definline c_pvm_pstat (fixnum) fixnum
"pvm_pstat(#0)"
)
(defun lpvm-pstat (tid)
(let ((info (c_pvm_pstat tid)))
(cond ((= info %PvmOk)
info)
((= info %PvmNoTask)
info)
(t
(pvm-error info "pvm_stat call")))))
(definline c_pvm_mstat (string) fixnum
"pvm_mstat(#0->st.st_self)"
)
(defun lpvm-mstat (hostname)
(unless (stringp hostname)
(error "lpvm-mstat: hostnames must be strings, not ~a~%"
(type-of hostname)))
(let ((info (c_pvm_mstat hostname)))
(cond ((= info %PvmOk)
'running)
((= info %PvmNoHost)
'no-such-host)
((= info %PvmHostFail)
'host-unreachable)
(t
(pvm-error info "pvm_mstat call")))))
(defcbody c_pvm_spawn (string fixnum string fixnum) object
"
Cnil;
{
int numt, tid, i;
int sz = #1;
object v;
extern object lisp_package;
siLmake_vector(7, intern(\"FIXNUM\", lisp_package),
MAKE_FIXNUM(sz), Cnil, Cnil, Cnil, Cnil, Cnil);
v = VALUES(0);
numt = pvm_spawn(#0->st.st_self, 0, #1, #2->st.st_self, #3, v->v.v_self);
if (numt < PvmOk) RETURN(1);
VALUES(0) = MAKE_FIXNUM(numt);
VALUES(1) = v;
RETURN(2);
}"
)
(defun lpvm-spawn (taskname flag where numtasks)
(cond ((not (stringp taskname))
(error "spawn -- wrong type: ~A" (type-of taskname)))
((not (integerp flag))
(error "spawn -- wrong type: ~A" (type-of flag)))
((not (stringp where))
(error "spawn -- wrong type: ~A" (type-of where)))
((not (integerp numtasks))
(error "spawn -- wrong type: ~A" (type-of numtasks)))
((not (and (<= 1 numtasks)
(<= numtasks 32)))
(error "spawn -- wrong number of tasks: ~D" numtasks))
(t
(multiple-value-bind (num-spawned tids)
(c_pvm_spawn taskname flag where numtasks)
(if (minusp num-spawned)
(pvm-error num-spawned "pvm_spawn call")
(values num-spawned tids))))))
(definline c_pvm_sendsig (fixnum fixnum) fixnum
"pvm_sendsig(#0,#1)"
)
(defun lpvm-sendsig (tid signum)
(let ((info (c_pvm_sendsig tid signum)))
(when (minusp info)
(pvm-error info "pvm_sendsig call")))
(values))
(definline c_pvm_advise (fixnum) fixnum
"pvm_advise(#0)"
)
(defun lpvm-advise (route)
(let ((info (c_pvm_advise route)))
(unless (= info %PvmOk)
(pvm-error info "pvm_advise call")))
(values))
;;;;
;;;; Group operations.
;;;;
(definline c_pvm_join_group (object) fixnum
"pvm_joingroup(#0->st.st_self)"
)
(defun lpvm-join-group (group)
(unless (stringp group)
(error "lpvm-join-grou expects a string, not a ~a~%"
(type-of group)))
(let ((inum (c_pvm_joingroup group)))
(when (minusp inum)
(pvm-error inum "pvm_joingroup call"))
inum))
(definline c_pvm_leave_group (object) fixnum
"pvm_lvgroup(#0->st.st_self)"
)
(defun lpvm-leave-group (group)
(unless (stringp group)
(error
"lpvm-leave-group expects a string, not a ~a~%"
(type-of group)))
(let ((info (c_pvm_leave_group group)))
(when (minusp info)
(pvm-error info "pvm_lvgroup call")))
(values))
(definline c_pvm_get_tid (object fixnum) fixnum
"pvm_gettid(#0->st.st_self, #1)"
)
(defun lpvm-get-tid (group inum)
(unless (stringp group)
(error
"lpvm-get-tid expects arg 1 to be a string, not a ~a~%"
(type-of group)))
(unless (integerp inum)
(error
"lpvm-get-tid expects arg 2 to be an int, not a ~a~%"
(type-of inum)))
(let ((info (c_pvm_get_tid group inum)))
(cond ((plusp info)
info)
((minusp info)
(pvm-error info "pvm_gettid call"))
(t
(pvm-error 0 "pvm_gettid: should not happen")))))
(definline c_pvm_get_inst (object fixnum) fixnum
"pvm_getinst(#0->st.st_self, #1)"
)
(defun lpvm-get-inst-no (group tid)
(cond ((not (stringp group))
(error
"lpvm-get-inst-no expects arg1 to be a string, not a ~a~%"
(type-of group)))
((not (integerp tid))
(error
"lpvm-get-inst-no expects arg2 to be an int, not a ~a~%"
(type-of tid)))
(t
(let ((inum (c_pvm_get_inst group tid)))
(when (minusp inum)
(pvm-error inum "pvm_getinst call"))
inum))))
(definline c_pvm_grpsize (object) fixnum
"pvm_gsize(#0->st.st_self)"
)
(defun lpvm-group-size (group)
(unless (stringp group)
(error
"lpvm-group-size expects a string not a ~a~%"
(type-of group)))
(let ((size (c_pvm_grpsize group)))
(when (minusp size)
(pvm-error size "pvm_gsize call"))
size))
(definline c_pvm_barrier (object fixnum) fixnum
"pvm_barrier(#0->st.st_self,#1)"
)
(defun lpvm-barrier (group count)
(cond ((not (stringp group))
(error
"lpvm-barrier expects arg 1 to be a string, not a ~a~%"
(type-of group)))
((not (integerp count))
(error
"lpvm-barriet expects arg 2 to be an int, not a ~a~%"
(type-of count)))
(t
(let ((info (c_pvm_barrier group count)))
(unless (= %PvmOk info)
(pvm-error info "pvm_barrier call")))))
(values))
(definline c_pvm_broadcast (object fixnum) fixnum
"pvm_bcast(#0->st.st_self,#1)"
)
(defun lpvm-broadcast (lisp-object
reader-object
message-type
group-name
&optional (encoding %PvmDataDefault))
(lpvm-init-send encoding)
(write-object lisp-object reader-object)
(let ((info (c_pvm_broadcast group-name message-type)))
(when (minusp info)
(pvm-error info "pvm_bcast call")))
(values))
(defCbody c_pvm_probe (fixnum fixnum) fixnum
"0;
{ int bufid, info;
int *bytes;
int out_tid, out_tag;
VALUES(0) = Cnil;
bufid = pvm_probe(#0,#1);
if (bufid == 0) RETURN(1);
if (bufid < 0) {
VALUES(0) = CONS(MAKE_FIXNUM(bufid), Cnil);
RETURN(1);
}
info = pvm_bufinfo(bufid,bytes,&out_tag,&out_tid);
VALUES(0) = list(3, MAKE_FIXNUM(info), MAKE_FIXNUM(out_tag),
MAKE_FIXNUM(out_tid));
RETURN(1);
}"
)
(defun lpvm-probe (tid msgno)
(let ((return-val (c_pvm_probe tid msgno)))
(let ((num-returned (length return-val))
(out-tid 0)
(out-tag 0)
(info 0))
(cond ((= num-returned 1)
(pvm-error (car return-val) "pvm_probe call"))
(t
(setf info (first return-val))
(setf out-tag (second return-val))
(setf out-tid (third return-val))
(if (= info %PvmOk)
(values out-tid out-tag)
(pvm-error info "pvm_probe call")))))))
;;;;
;;;; Add and delete hosts.
;;;;
;;
;; add_host adds a single host to the machine. hostname is the
;; string name of the host. The function returns a pair.
(defCbody c_pvm_add_host (object) object
"Cnil;
{ int host_info[1];
int info, hival;
info = pvm_addhosts(&(#0)->st.st_self,1,host_info);
hival = host_info[0];
VALUES(0) = list(2, MAKE_FIXNUM(info), MAKE_FIXNUM(hival));
RETURN(1);
}"
)
(defun add-hosts (hostnames)
(let ((results (make-array (length hostnames))))
(dotimes (host (length hostnames))
(let ((host (aref hostnames)))
(c_pvm_add_host host)
(setf (aref results host)(cadr host))))
results))
(defCbody c_pvm_del_host (object) object
"Cnil;
{ int host_info[1];
int info, hival;
info = pvm_delhosts(&(#0)->st.st_self,1,host_info);
hival = host_info[0];
VALUES(0) = list(2, MAKE_FIXNUM(info), MAKE_FIXNUM(hival));
RETURN(1);
}"
)
(defun del-hosts (hostnames)
(let ((results (make-array (length hostnames))))
(dotimes (host (length hostnames))
(let ((host (aref hostnames)))
(c_pvm_add_host host)
(setf (aref results host) (cadr host))))
results))

620
contrib/pvm/pvmlisp.lsp Normal file
View file

@ -0,0 +1,620 @@
;;;-*-Mode: LISP; Syntax: Common LISP; Base: 10-*-
;;;
;;; File = pvmlisp.lsp
;;;
;;; New version of reader structure using vectors.
;;;
;;;
;;; This code only works with Common LISP. It should not be included
;;; in a CLOS program (yet). It will also not work with CLiCC.
;;;
;;;
;;; Message-start-p is used to detect the start of a complex message.
;;; It is true if it is applied to a message tag.
;;;
(defun message-start-p (mty)
(and (integerp mty)
(= MESSAGE_START mty)))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; We define the reader object. This is a structure containing ;;;;
;;;; the function closures which perform the encoding and decoding. ;;;;
;;;; We begin by defining the encoder and decoder structures and ;;;;
;;;; manipulation functions (this will be a dream in CLOS or ;;;;
;;;; TELOS!) ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
;;;
;;; The encoder structure.
;;; The design of the encoder is such that it allows users to configure
;;; their own encoders. For example, CMU CL calls a SIMPLE-STRING a
;;; SIMPLE-BASE-STRING. This can be accomodated within this organisation
;;; at the cost of a little effort.
;;;
(defstruct encoder-rec
typename ;; value returned by type-of and used to index the
;; encoder function
msgtypeno ;; the numeric message type
encoder-fn)
;;;
;;; Encoders are held in hash tables. The following function (which
;;; should be inline) creates such a table.
;;;
;(declaim (inline make-encoder-structure))
(proclaim '(inline make-encoder-structure))
(defun make-encoder-structure ()
(make-hash-table :test #'eq))
;;;
;;; encoder-present-p is true if there is an encoder for the
;;; named type in the encoder table.
;;;
(defun encoder-present-p (enc-struc typename)
(multiple-value-bind (encrec there)
(gethash typename enc-struc)
(declare (ignore encrec))
there))
;;;
;;; Retrieval function for encoders. Given a type name, it returns the
;;; encoder function associated with the type.
;;;
(defun get-encoder (enc-struc typename)
(multiple-value-bind (encoder-rec known-type)
(gethash typename enc-struc)
(if known-type
(encoder-rec-encoder-fn encoder-rec)
())))
;;;
;;; Routine to store an encoder function.
;;; Assumes that typename and typeno have been checked.
;;;
(defun put-encoder (enc-struc typename typeno encoder-fn)
(setf (gethash typename enc-struc)
(make-encoder-rec :encoder-fn encoder-fn
:typename typename
:msgtypeno typeno))
(values))
;;;****************************************************************;;;
;;; ;;;
;;; ;;;
;;; A routine to replace the encoder function and a routine to ;;;
;;; remove an encode could be added here. ;;;
;;; ;;;
;;; ;;;
;;;****************************************************************;;;
;;;
;;; message-type-number returns the type number associated with a
;;; symbolic type name. Its input is an encoder structure.
;;;
(defun message-type-number (enc-struc typename)
(multiple-value-bind (enc-rec known-type)
(gethash typename enc-struc)
(if known-type
(encoder-rec-msgtypeno enc-rec)
(error "cannot return type number for type ~a: unknown type.~%"
typename))))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; The decoder structure and containing object. ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
;;;
;;; The decoder is indexed by its message type number.
;;; Decoders have a symbolic identifier associated with them.
;;;
(defstruct decoder-rec
typename
decoder-fn)
;;;
;;; Decoders are held in a hash table. The table is indexed by the
;;; message number. The hash table representation is used so that
;;; users can have gaps in their message number sequences.
;;;
;(declaim (inline make-decoder-structure))
(proclaim '(inline make-decoder-structure))
(defun make-decoder-structure ()
(make-hash-table :test #'eql))
;;;
;;; decoder-present-p is true if there is a decoder structure
;;; in the decoder table at the point indexed by the numeric
;;; message type.
;;;
(defun decoder-present-p (dec-struc msg-type-no)
(multiple-value-bind (decrec there)
(gethash msg-type-no dec-struc)
(declare (ignore decrec))
there))
;;;
;;; get-decoder returns the decoder function associated with a
;;; message type number. If there is no such message, an error is raised.
;;;
(defun get-decoder (decoder-struc msg-no)
(multiple-value-bind (decrec there)
(gethash msg-no decoder-struc)
(if there
(decoder-rec-decoder-fn decrec)
())))
;;;
;;; put-decoder inserts a decoder record into the decoder vector.
;;; If a decoder structure is already in the vector at the place
;;; indexed by the message number, an error is raised.
;;;
;;; Note that this function will expand the vector if there is
;;; insufficient room.
;;;
(defun put-decoder (decoder-struc msg-no msg-typename decoder-fn)
(setf (gethash msg-no decoder-struc)
(make-decoder-rec :typename msg-typename
:decoder-fn decoder-fn))
(values))
;;;****************************************************************;;;
;;; ;;;
;;; ;;;
;;; A routine to replace the decoder function and a routine to ;;;
;;; remove an encode could be added here. ;;;
;;; ;;;
;;; ;;;
;;;****************************************************************;;;
;;;
;;; message-number-type returns the symbolic name associated with
;;; a numeric message type.
;;;
(defun message-number-type (decoder-struc msg-type-no)
(decoder-rec-typename
(aref decoder-struc msg-type-no)))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; The reader object and its associated functions. ;;;;
;;;; Note that encoder and decoders can be added or removed at ;;;;
;;;; runtime. ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
(defstruct reader-object
(encoders (make-encoder-structure))
(decoders (make-decoder-structure))
(known-type-names ()))
;;;
;;; A creation function for readers.
;;;
(defun make-object-reader ()
(make-reader-object))
;;;
;;; add-type-name adds a symbolic type name to the reader object.
;;;
;(declaim (inline add-type-name))
(proclaim '(inline add-type-name))
(defun add-type-name (reader-obj typename)
(pushnew typename
(reader-object-known-type-names reader-obj)
:test #'eq)
(values))
;;;; A deletion function can easily be defined.
;;;
;;; valid-type-name-p is true iff the type name supplied as
;;; the second argument is known to the reader supplied as the
;;; first argument.
;;;
;(declaim (inline valid-type-name-p))
(proclaim '(inline valid-type-name-p))
(defun valid-type-namex-p (reader-obj typename)
(member typename
(reader-object-known-type-names reader-obj)
:test #'eq))
;(declaim (inline known-type-name-p))
(proclaim '(inline known-type-name-p))
(defun known-type-name-p (reader-obj typename)
(member typename
(reader-object-known-type-names reader-obj)
:test #'eq))
;;;
;;; valid-message-type-no-p is true if the message type number
;;; supplied as the second argument is (i) positive and (ii) in the
;;; range 0 .. (length decoders)
;;;
;(declaim (inline valid-message-type-no-p))
(proclaim '(inline valid-message-type-no-p))
(defun valid-message-type-no-p (reader-obj msg-typeno)
(multiple-value-bind (decrec present)
(gethash msg-typeno
(reader-object-decoders reader-obj))
(declare (ignore decrec))
present))
;(declaim (inline known-type-number-p))
(proclaim '(inline known-type-number-p))
(defun known-type-number-p (reader-obj msg-typeno)
(multiple-value-bind (decrec present)
(gethash msg-typeno
(reader-object-decoders reader-obj))
(declare (ignore decrec))
present))
;;;
;;; Routines to add encoder and decoder functions to a reader object.
;;; They can be called at runtime as well as at configuration time.
;;; Procedures to replace readers and writers could be defined if
;;; necessary---they won't be too difficult.
;;;
(defun add-encoder (reader-obj ;; the reader object
message-type-no ;; the numeric type of the
;; message type
message-type-name ;; the symbolic name of the
;; message type
encoder-function) ;; the encoder function proper
; start by checking that the type is not already known.
(when (and (known-type-name-p reader-obj message-type-name)
(encoder-present-p (reader-object-encoders reader-obj)
message-type-name))
(error
"add-encoder: cannot add encoder for ~a -- one already present~%"
message-type-name))
; try to add the type name (a decoder might have put it there already)
(add-type-name reader-obj message-type-name)
; add the encoder function
(put-encoder (reader-object-encoders reader-obj)
message-type-name
message-type-no
encoder-function)
(values))
(defun add-decoder (reader-obj ;; the reader object
message-type-no ;; the numeric type of the
;; message type
message-type-name ;; the symbolic name of the
;; message type
decoder-function) ;; the encoder function proper
; start by checking that the type is not already known
(when (and (known-type-name-p reader-obj message-type-name)
(decoder-present-p (reader-object-decoders reader-obj)
message-type-no))
(error
"add-decoder: cannot add decoder for ~a -- one already present~%"
message-type-name))
; try to add the type name (an encoder might have already added it)
(add-type-name reader-obj message-type-name)
; add the decoder function
(put-decoder (reader-object-decoders reader-obj)
message-type-no
message-type-name
decoder-function)
(values))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; Some utility functions. ;;;;
;;;; ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
;;;
;;; Only proper lists can be transmitted and received -- sorry.
;;;
(defun proper-listp (l)
(and (not (null l))
(list l)
(null (cdr (last l)))))
;;;
;;; type-name is used in indexing the encoders.
;;;
(defun type-name (typ)
(if (symbolp typ)
typ
(car typ)))
;;;
;;; initialise-reader-object takes a reader object as its first
;;; argument and a list of lists of the following form:
;;; (typename -- a symbol
;;; typeno -- a natural number (one of the LISP_X_TYPEs)
;;; encoder -- a closure or the symbol '*
;;; decoder -- a closure or the symbol '*
;;; )
;;;
(defun initialise-reader-object (reader-obj ;; the reader to be started.
specs) ;; a list of reader and writer
;; specifications
(dolist (spec specs)
(let ((typename (first spec))
(typeno (second spec))
(encfn (third spec))
(decfn (fourth spec)))
(when (and (symbolp encfn)
(eq encfn '*)
(symbolp decfn)
(eq decfn '*))
(error
"initialise reader: reader and writer for ~a both unspecified.~%"
typename))
(unless (and (symbolp encfn)
(eq '* encfn))
; add an encoder.
(add-encoder reader-obj typeno typename encfn))
(unless (and (symbolp decfn)
(eq '* decfn))
(add-decoder reader-obj typeno typename decfn))))
(values))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; Routines to apply encoders and decoders. These are the core ;;;;
;;;; of the module. ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
(defun apply-encoder (objectreader ;; reader in which to look for encoder
lisp-object) ;; object to encode
(let ((tname (type-name (type-of lisp-object))))
(cond ((not (known-type-name-p objectreader tname))
(error
"apply-encoder: cannot encode -- unknown type ~a for object ~a~%"
tname
lisp-object))
(t
(let ((encode-fn (get-encoder
(reader-object-encoders objectreader)
tname)))
(cond ((null encode-fn)
(error
"apply-encoder: no writer function for type ~a~%"
tname))
(t
(funcall encode-fn lisp-object objectreader)))))))
(values))
(defun apply-decoder (objectreader ;; the reader in which to look
message-type-no) ;; the number of the message
(cond ((not (known-type-number-p objectreader message-type-no))
(error
"apply-decoder: cannot decode -- unknown message type number ~d~%"
message-type-no))
(t
(let ((decoder-struc (reader-object-decoders objectreader)))
(let ((decoder-fn (get-decoder decoder-struc message-type-no)))
(if (null decoder-fn)
(error
"apply-decoder: no reader function for type ~a~%"
(message-number-type decoder-struc message-type-no))
(funcall decoder-fn objectreader)))))))
;;;****************************************************************;;;
;;; ;;;
;;; User interface functions. ;;;
;;; ;;;
;;;****************************************************************;;;
(defun write-object (object reader)
(apply-encoder reader object))
(defun write-user-object-type (object reader)
(let ((encoders (reader-object-encoders reader)))
(multiple-value-bind (encrec there)
(gethash (type-name (type-of object))
encoders)
(if there
(let ((msgno (encoder-rec-msgtypeno encrec)))
(when (>= msgno LISP_MIN_USER_TYPE)
(C-set-message-type msgno)))
(error
"write-object: no encoder information for type ~a~%"
(type-name (type-of object)))))))
(defun read-object (reader)
(let ((next-object-type (C-next-msg-type)))
(format t "got next type: ~A~%" (type-of next-object-type))
(when (message-start-p next-object-type)
(setf next-object-type (C-next-type-name)))
(apply-decoder reader next-object-type)))
(defun add-writer (reader type-no type-name writer-fn)
(add-encoder reader type-no type-name writer-fn))
(defun add-reader (reader type-no type-name writer-fn)
(add-decoder reader type-no type-name writer-fn))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; Readers and writers for vectors and lists. ;;;;
;;;; These should be used as default (they are, in any case, ;;;;
;;;; portable). ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
;(declaim (inline ok-message-type))
(proclaim '(inline ok-message-type))
(defun ok-message-type (rdr type-no)
(known-type-number-p rdr type-no))
;;;
;;; Writer (encoder) for vectors.
;;; Vectors must be of type SIMPLE-VECTOR.
;;;
(defun encode-vector (vec objreader)
(let ((len (length vec))) ;; get the length for the header.
;; call the C primitive for stuffing the length
;; into the PVM buffer
(C-obuffer-vector-header len)
;; iterate over the vector, encoding each item and
;; stuffing it into the buffer.
(dotimes (i len)
(apply-encoder objreader (aref vec i)))
;; when control drops out of the bottom of this loop,
;; the vector has been encoded.
))
;;;
;;; Reader (decoder) for vectors.
;;;
(defun decode-vector (objreader)
;; we know we have a vector, so get the length by
;; calling the C primitive.
(let ((vector-len (C-ibuffer-vector-length)))
(cond ((minusp vector-len)
(error "Cannot read vector: negative length ~d~%"
vector-len))
((zerop vector-len)
(make-array '(0)))
(t
(let ((vec (make-array (list vector-len))))
;; create a new vector and try to fill its elements
(dotimes (i vector-len)
(let ((next-obj-type ;; get the type of the next
;; object to be decoded from a C
;; routine
(C-next-msg-type)))
(when (not (ok-message-type objreader next-obj-type))
;; call a routine to check that there is an object
;; that comes next.
(error "Cannot read vector: invalid type ~s~%"
next-obj-type))
(when (message-start-p next-obj-type)
(setq next-obj-type (C-next-type-name)))
(let ((next-elem (apply-decoder objreader next-obj-type)))
(setf (aref vec i) next-elem))))
vec)))))
;;;
;;; Writer (encoder) for lists.
;;; Lists must be PROPER lists.
;;;
(defun encode-list (list-to-go objreader)
;; First ensure that we have a proper list.
(unless (proper-listp list-to-go)
(error
"encode-list: input list is not proper~% ~s ~%-- cannot encode, sorry.~%"
list-to-go))
;; The list header should have been put into the output buffer.
;; Remember that the end of the list has to be a nil message object.
;; So: mark the object to go as a list by calling the C routine.
;; (Perhaps the length could also be encoded for extra checking---
;; perhaps not.)
;; OK. Run over the list and encode the elements.
(C-obuffer-list-header)
(mapc ; or dolist or explicit manipulation---it doesn't matter
#'(lambda (element)
(apply-encoder objreader element))
list-to-go)
;; finally, put a NIL into the output buffer to say that it's the
;; end: do this by calling the C routine.
(C-obuffer-nil)
(values))
;;;
;;; Reader (decoder) for lists.
;;;
(defun decode-list (objreader)
;; When we're called, we know we have a list.
;; We need to iterate until we get a nil object.
;; (Problem: what happens if there is no nil at the end??)
(let ((newlist ()) ;; the list we're going to build.
(next-item-type ())) ;; the type of the next object in the
;; input buffer
(loop
(setq next-item-type (C-next-msg-type))
(when (not (ok-message-type objreader next-item-type))
(error "cannot decode list: invalid type ~s~%"
next-item-type))
(cond ((= next-item-type LISP_NIL_TYPE)
(return)) ; got the end of the list.
((message-start-p next-item-type)
(setq next-item-type (C-next-type-name))
(push (apply-decoder objreader next-item-type) newlist))
(t
(push (apply-decoder objreader next-item-type) newlist))))
(reverse newlist)))
;;;;****************************************************************;;;;
;;;; ;;;;
;;;; An example of how to define a reader and a writer for a ;;;;
;;;; structure (the same outline applies to classes). ;;;;
;;;; ;;;;
;;;;****************************************************************;;;;
#|
(defparameter *rdr* (make-object-reader))
(defstruct foo slot1 slot2)
(defconstant foo-type 32)
(defun write-foo (obj rdr)
(write-object (foo-slot1 obj) rdr)
(write-object (foo-slot2 obj) rdr))
(defun read-foo (rdr)
(let ((s1 (read-object rdr))
(s2 (read-object rdr)))
(make-foo :slot1 s1 :slot2 s2)))
(add-writer *rdr* foo-type 'foo #'write-foo)
(add-reader *rdr* foo-type 'foo #'read-foo)
|#

2062
contrib/thread.patch Normal file
View file

File diff suppressed because it is too large Load diff

4
site.lsp Normal file
View file

@ -0,0 +1,4 @@
;; Edit these with the name of your site:
;;
(defun short-site-name () "SHORT-SITE-NAME")
(defun long-site-name () "LONG-SITE-NAME")

697
src/CHANGELOG Normal file
View file

@ -0,0 +1,697 @@
ECL-Spain v0.0
==============
* Removed all "break" from the configure script.
* Added latexinfo.sty to help producing the manual.
* src/configure.in: profile feature disable by default.
* Conversion to ANSI prototypes of all files in the library (c/)
directory. Two headers, external.h and lisp_external.h, to keep the
prototypes of C and LISP functions.
* Fixed lack of "extern" declaration for {short,long}float_zero and
lack of implementation.
* Fixed lack of "extern" declaration of r frame_stack, frs_limit and
frs_top. Actual implementation added in main.c.
* Fixed lack of "extern" declaration for Values in the THREADS case,
in vs.h
* Removed OFLAG as the standard is using CFLAGS
* Added test tree from CLISP
* Removed 'break's from configure.
* Grouped all keyword definitions in a single pool in the new file
all_keywords.c
* Grouped all symbol definitions in a single pool in the new file
all_symbols.c
* Removed all calls to register_root() for symbols from the
library. Instead the garbage collector uses the symbol/keyword
definition pools to mark these objects.
* parse_number() failed when GC was triggered. The reason was that
GC did only reallocate num.size limbs when it should actually move
num.alloc limbs. This has been solved in three steps
+ The GC uses num.alloc (= big_dim)
+ The allocator clears the bignum
+ The bignum data is only relocated when the pointer is valid,
that is, we assume that big_limbs may point to non
collectable memory.
* The allocator empties a region before returning it.
* All big_*() functions now get lisp objects as input, in order to
make the interface more abstract.
* Added #'nth-value
* Now big_alloc(), alloc_contblock() and alloc_relblock() fail when
passed a negative argument.
* Created a pool of three bignum registers. These registers may be
used to save consing, as the destination of mpz_* operations, as
follows
+ Perform a big_register?_get()
+ Perform elementary operations from the GMP library
+ Either discard the object, use big_register_copy() or use
big_register_normalize().
* Removed most preallocations of bignums, favoring the use of bignum
registers.
* In integer_quotient_remainder, if both operands are bignums and the
divisor is larger, a bignum with negative size was allocated. The
use of bignum registers fixes this problem.
* In parse_number() and parse_integer(), use the bignum registers to
store the intermediate result.
* Implementation of a new stream mode, smm_closed.
* Fresh streams from alloc_object() are smm_closed streams.
* In file.d: 1) input_stream_p, output_stream_p, stream_element_type,
readc_stream, unreadc_stream, writec_stream, flush_stream,
clear_input_stream, clear_output_stream, stream_at_end,
listen_stream, file_position, file_position_set, file_length,
file_column fail on closed streams. 2) close_stream and
Lopen_stream_p work on closed streams.
* In read.d, print.d: Lread_bytes and Lwrite_bytes which could have
tried to access a closed stream. Not a good fix, anyway.
* array.tst, hashlong.tst, eval20.tst, iofkts.tst, lists152.tst: added #+ECL.
* In pathname.d: coerce_to_pathname makes sense on closed streams.
* In print.d: print() did not output a trailing space.
* In read.d: #'read-char-no-hang now handles EOF and fails or returns
eof-value when appropiate.
* In format.c: Lformat formerly output a string for non-nil first
argument.
* In symbols.c, all_symbols.c, lisp_externals.h: implemented
*gensym-counter*
* In symbols.tst: placed (setq *gensym-counter*...) right before
creating the symbol --otherwise a spurious gensym is produced by the
interpreter.
* predlib.lsp: errata in subtypep caused failure for '(not ....) and
'(and ...) types.
* predlib.lsp: #'normalized-type now turns (integer a (b)) into
`(integer a ,(1- b)), producing an output which is suitable for
sub-interval-p.
* predlib.lsp: #'typep now rejects type specifiers that it doesn't
know about. For instance, '(symbol cons) is rejected.
* predlib.lsp: #'typep on '(MEMBER ...) now only outputs T or NIL.
* strings.tst: added #+ECL and now included in the test-suite.
* string.d: member_char() hangs when the character bag has some
non-character objects.
* string.d: nstring-{up,down}case now reject NIL as bound designator
when compiled in ANSI compatibility mode.
* characters.tst: added #+ECL and included in the test-suite.
* pack11.tst: the keyword :use from #'in-package needs a list, no
a single symbol. Added to the test.
* package.d: packages must be case sensitive. This implies changes in
find_package()
* package.d: #'package-name should also accept symbols and strings.
* package.d: #'unexport should ignore internal symbols.
* Makefile.in: makes tar file.
* in system.lsp: new syntax for defsystem, takes care of multiple
source directories and separate path for library.
* in {lsp,cmp,clos}/defsys.lsp.in: modified with new syntax.
* in load.d: build_symbol_table is now a C function invoked from the
initialization code and not exported to lisp.
* in cmpmain.lsp: new #'build-ecl function to build customized
executables. It generates the initialization code.
ECL v0.0b
=========
* in lsp/predlib.lsp: extended #'typep to classes.
* in cmp/cmpdefs.lsp: added types for all compiler structures.
* in clos/standard.lsp: redefine-class should be evaluated at compile
time.
* in clos/: fixed everything to allow generation of *.c files.
* in lsp/predlib.lsp: subclassp now exported from LISP package.
* in c/pathname.d:
+ now pathnames are constructed according to ANSI. We support
:ABSOLUTE, :RELATIVE, :UP and :WILD, and we require their use when
constructing pathnames.
+ All pathnames are considered relative except those which begin
with '/' or '~/'. The last case is expanded using the $HOME
environment variable.
+ pathnames are merged according to ANSI CL. If 'pathname' is a
relative directory, it is merged with 'default's directory, no
matter whether this one is relative or not.
+ tilde_expand() hidden as static -- it is far too low level.
+ current_dir() and getcwd() substitutes all uses of getwd().
+ fixed size buffers removed from most routines to avoid accidental
overflows. Use of current_dir() and siLstring_concatenate() prevents
this type of errors.
* in c/unixfsys.c:
+ truename() rewritten to detect only files and signal errors when
it finds directories.
+ Ltruename() now returns the number of output values.
+ Lrename_file() now outputs true names by checking the renamed file
after the operation.
+ string_match() and siLstring_match() provide SH-like patterns.
+ Ldirectory() only lists files and allows all wildcards that
siLstring_match() provides. The implementation dependent keyword,
:LIST-ALL, instructs Ldirectory() to list both files, directories
and special nodes such as devices, pipes, etc.
* in c/read.d:
+ Added Lsharp_P_reader() to read paths using #P.
+ Ldefault_dispatch_macro() outputs clearer error message.
* in lsp/defstruct.lsp,lsp/iolib.lsp: sharp-s-reader and
sharp-s-reader-si now ignore data when *read-suppress*.
* in lsp/module.lsp: #"" replaced with #P"".
* in c/lwp.d,c/big.c: per-thread allocation bignum registers.
* in c/Makefile.in,gmp/Makefile.in: make use of './' to avoid the need
of exporting PATH with a '.' inside.
* in c/print.d: Now paths are printed as #P.
* in Makefile.in: BUILDIR mispelled caused failure of installation.
ECLS v0.0c
==========
* in src/configure.in: make using CLOS the default.
* in gmp/Makefile.in,gmp/mpz/Makefile.in: fixed recursive error in
cleaning.
* in lsp/iolib.lsp,lsp/packlib.lsp: removed use of ". body" favoring
the use of "&rest body" because sys::expand-defmacro doesn't
understand it.
* in c/gbc.c: added gc marking of objects in lexical envs.
* in c/macros.c: define-macro now uses default values for last two
arguments when they are missing.
* in c/clos.c,c/package.d,c/print.d,c/read.d: added register_root() to
some variables.
* in lsp/builtin.lsp: removed make-instance on structure-metaclass,
since it does not exist.
* in lsp/predlib.lsp:
+ implemented sequence as a deftype
+ removed sequence from subtypep
+ built normalize-type to return multiple values
+ recoded subtypep & coerce to use multiple values from normalize-type
+ when using clos, deftype structure as STRUCTURE-OBJECT
* in c/let.c: save values in Fmultiple_value_bind before performing
the actual let_bind. This prevents losing data within a GC.
* Now a raw ecl_min file is built which uses no lisp compiled files,
to provide a tool for bootstraping ECL. This implies some changes
to avoid circular dependencies
+ src/c/Makefile.in creates an init_min.o when bootstraping
+ src/Makefile.in uses init_min.o,c/*.o and crs/*.o to create the
raw ECL which we will use to bootstrap.
+ c/init.c now loads *.lsp files when bootstraping
+ lsp/defmacro.lsp postpones definition of defmacro until
sys::expand-defmacro is defined
+ lsp/defmacro.lsp does not use 'defvar because it is not defined.
+ lsp/iolib.lsp,lsp/module.lsp,lsp/packlib.lsp now use &optional
instead of . in macros, as defmacro does not support '.'
+ clos/method.lsp: when :ecl-min, replace *safe-compile* with t
+ cmp/load.lsp: replace call to object-type with its result.
+ new src/config_min.lsp which performs booting.
* in cmp/cmpinline.lsp: inline-args adds a bogus arg when inlining
instance-ref. This problem only arised when *safe-compile*.
* in lsp/defmacro.lsp:
+ #'sys::destructure handles destructuring lambda lists
+ #'defmacro reimplemented using #'sys::destructure, which now
handles '.' arguments properly.
+ new #'destructuring-bind implemented using #'sys::destructure
* in c/unixfsys.c: sys::chdir now outputs original directory.
* in h/: lisp_external.h and unify.h were missing from CVS.
in c/: all_symbols.c and all_keywords.c were missing from CVS.
in contrib: ilisp removed, there are better versions around.
* new src/compile.lsp.in, lsp/defsys.lsp.in, clos/defsys.lsp.in,
cmp/defsys.lsp.in, plus changes in src/config.lsp.in,
src/configure.in and src/Makefile.in: now the C files are
compiled on-the fly usin the bare feet ecl_min program.
ECLS v0.0d
==========
* in clos/generic.lsp: implemented :method in #'defgeneric
* in lsp/predlib.lsp: extended #'typep to classes and made #'subclassp
public.
* New codeblock object which keeps all information about an object
file and its data. It replaces the old tagless structure and
introduces a new format for init_*() function when initializing an
object file.
* Moved compiler data into object files as C string. This implies
changes in the loader (load.d), in the data stream reader
(read_VV) and in the compiler (cmpwt.lsp,cmpmain.lsp,cmptop.lsp)
which nows generates a different boot code for compiled lisp files.
* in cmp/cmpmain.lsp: new #'make-library joins several object files
into an *.a file, adding a new object file which initializes them
all and exports an init_*() routine.
* cmp/cmpmain.lsp: compiler-pass2 now upcases init_* names to avoid
name clashes with lisp code.
* in src/util/system.lsp: new :LIBRARY target which uses
compiler::make-library to produce *.a libraries up from CLOS, LSP
and CMP subdirectories.
* in src/c/Makefile.in: now a library libecls.a is built up from
all object files except cinit*.o
* in src/Makefile.in, src/compile.lsp: ecl_min is built up only from
the core C library, while ecl is built with this core and all
required libraries liblsp.a, libcmp.a, libclos.a, etc, plus
config.o. To help in this compile.lsp is used to build all required
libraries.
* load.d: siLbuild_symbol_table no longer removes ecl.sym
* in c/main.c,c/cinit.c,c/load.d: removed system_directory C variable.
The lisp variable *system-directory* is used instead and points to
the system files (headers, libraries, initialization code). Default
value for this one is assigned during the configuration phase and
defaults to @libdir@
* in cmp/cmpmain.lsp: <ecl.h> header is no longer copied onto the
compiled code, but #inlined from the system directory.
* in c/package.d, c/assignment.c, c/macros.c, c/toplevel.c,
h/object.h: new function #'sys::package-lock locks a package and
subsequents redefefinitions of functions/macros produce a warning.
* config.lsp moved to lsp/config.lsp and compiled into interpreter.
* in Makefile.in, src/Makefile.in: primitive installation method,
which stores $(bindir)/ecl, $(mandir)/man.1, $(libdir)/ecl.sym,
$(libdir)/help.doc and $(libdir)/h/ecl.h
ECLS v0.0e
==========
* Support for FreeBSD >= 4.0 using ELF.
* Defined ANSI and #+ansi by default, except in number_atan(), which
needs fixing.
* in package.d: lisp package renamed to common-lisp with nicknames
"lisp" and "cl", and user package renamed to common-lisp-user with
nicknames "cl-user" and "user".
* in export.d: common-lisp-user, cl, cl-user, common-lisp added to
export list of common-lisp package.
* in defsys.lsp: ansi.lsp, loop.lsp and defpackage.lsp incorporated.
* in package.d: shadow did not shadow already interned objects.
* in toplevel.c: added :execute, :compile-toplevel and :load-toplevel
to eval-when.
* in list.d: fixed #'last adding optional argument
* in src/util/system.lsp: new syntax which allows separate directory
for library.
* src/config.lsp.in moved to src/lsp/config.lsp.in and incorporated
into liblsp.a
* in cmp/cmpmain.lsp: new #'build-ecl to build customized executables.
{lsp,cmp,clos}/defsys.lsp.in updated accordingly.
* in src/Makefile.in: new build process relying entirely on lisp and
defsystem to build executables.
* in print.d: when *print-escape* is nil, pathnames are written as
addresses -- now the namestring is output.
* in predicate.c: functionp = 't on symbols bound to functions.
* in src/Makefile.in: strip executables.
* in lsp/seq.lsp: #'make-sequence was broken due to new #'normalize-type.
* in lsp/predlib.lsp: #'coerce was broken due to new #'normalize-type.
Plus a quick hack to handle 'LIST properly.
* in cmp/cmpmain.lsp: #'build-ecl now also strips symbols using
"rsym", which gets installed into @libdir@
* Simplified the set of headers. Now there is a ecls.h for base code
and ecls-cmp.h for lisp compiled code, both sharing the rest of
headers (stacks.h, object.h, etc), to simplify maintenance.
ECLS v0.0g
==========
* Binding stack, invocation history stack and frame stack predate now
ordinary memory as a first step for future resizable stacks.
* Built in C strings are better handled now: they can contain \000 and
make use of \n,\t,\\, and of special characters in octal notation.
* Final problems with documentation solved. #'si::help no longer hangs
and the database is now properly generated (in v0.0e only a few
entries got in).
* New online manual in texinfo format gets installed.
* Support for character attributes removed, including #'char-bit,
#'char-font, #'make-character, #'string-char-p and 'string-char
type. Instead, the whole chapter of the ANSI spec is implemented
with types character = base-char > standard-char and extended-char
being an empty type.
* Initialization of functions grouped in a single file all_functions.c.
* Full ANSI compliance for CHARACTER and STRING sections of the spec.
* (type-of nil) now returns 'NULL instead of 'SYMBOL.
* Different hierarchy of tags in object.h saves some space & time.
* Open-coded caar, cadr, etc, are faster & smaller.
* In old garbage collector, flag *IGNORE-MAXIMUM-PAGES* turned into
function #'si:ignore-maximum-pages
* Added support for Boehm-Weiser garbage collector with flag
--enable-boehm.
* Removed support for relocatable blocks of memory from original
garbage collector. Unified allocation interface with alloc(),
alloc_align(), dealloc() and the alloc_atomic() and
alloc_atomic_align() variants.
ECLS v0.0h
==========
* big_bitp() was broken due to the use of wrong limb sizes. Furthermore,
it did not consider the case of negative bignums.
* gmp-3.1 takes the place of the original gmp-1.
* Now it is possible to link ECLS with a local copy of the GMP library,
avoiding to compile and install the copy that comes with it.
* New C functions floor1, floor2, ceiling1, ceiling2, truncate1,
truncate2, round1, round2 which correspond to #'floor, #'ceiling,
#'truncate and #'round with one or two arguments, but which are only
used internally. Lfloor, Lceiling and Ltruncate implemented using
them.
* Rewritten many routines optimizing and removing or completing type
checks. For instance, make_complex(),
number_{plus,minus,times,divide}(), integer_divide(), log_op(), etc.
* At cost of some speed, the interpreter (i.e. not compiled code)
keeps track of all called functions for better error signaling.
* Some failed type checks are now restartable in most cases in which
it is safe. This allows the user to dynamically supply a different
value
> (make-list 'a :initial-element 'b)
Correctable error: A is not of type (INTEGER 0 *).
Signalled by MAKE-LIST.
If continued: Enter new value.
;;; Warning: Clearing input from *debug-io*
Broken at MAKE-LIST.
>> :b
Backtrace: > MAKE-LIST
>> :continue
Enter new value> 10
(B B B B B B B B B B)
>
The jump to the debugger may be suppressed by binding *break-enable*
to nil.
> (setq *break-enable* nil)
NIL
> (make-list 'a :initial-element 'b)
Correctable error: A is not of type (INTEGER 0 *).
Signalled by MAKE-LIST.
Aborting:
>
* Support for logical pathnames. The syntax for logical pathnames is
[hostname:][;][directory-item;][name][.type]
and the syntax for physical pathnames is extended to
[device:][[//hostname]/][directory-item/][name][.type]
where device defaults to "file". Pathname translation and matching
is also implemented, although wildcard expansion is not maximal
and works more like "sh" than like "regexp".
* New set of C types which includes: cl_object for all lisp objects,
cl_fixnum for an integer large enough to hold a fixnum, cl_index for
an unsigned integer large enough to index an array, cl_hashkey for
hashing and cl_type for all type tags.
* New macros LISTP(), ATOM(), CONSP(), SYMBOLP() optimize type checks
within the library code and within automatically generated C
compiled code.
* Errors fixed:
+ Removed non-standard keyword argument :staticp from #'make-array
and #'make-vector.
+ A fixnum is no longer a valid string designator.
+ #'butlast and #'nbutlast now work with dotted lists.
+ Inlined #'tan now produces the right code.
+ A fixnum cannot be coerced to a character.
+ Character bags of type vector would produce erroneous results.
+ #'equalp would fail to compare complex numbers
+ #'char now only accepts strings
+ in pathnames, namestrings, etc, symbols are not implicitely
coerced to strings.
* The Common-Lisp reader has been reworked to allow an unlimited
number of #= and ## references in circular structures. Besides, this
also fixes the accidental deactivation of the #=/## readers in ECLS
v0.0g :(
* Errors detected but not yet fixed throught all bit manipulating
functions: they fail to fake two's complement convention for
negative bignums.
* Big change of names in structure members: ht.ht_size -> hash.size,
etc. Less redundant and more expressive.
* Packages are now stored in a list. The link in the package object
has been removed. We make sure this list is garbage collected by
applying "register_root()" on it. Garbage collection of package
objects is now moved into the mark_object() routine.
ECLS 0.0i
=========
* Replaced hashing function with a crc32.
* Packages now use standard hashes for storing symbols. This seems
to reduce the amount of wasted memory at now speed cost. Besides,
future improvements to hashes will get in packages as well.
* The interpreter is now capable of passing the whole suite of tests.
Just issue "make ecls_min_test" from within build/test directory.
* Errors can be ignored by setting si:*ignore-errors* to true. If this
happens, a (throw si:*ignore-errors-tag* 'ERROR) is thrown. Hence
a useful construct for testing is
(defmacro with-ignored-errors (&rest forms)
`(catch si::*ignore-errors-tag*
(let ((si::*ignore-errors* t)) ,@forms)))
* Improvements to the "dpp" preprocessor that generates code for the
core library:
+ All C code is now run by the preprocessor.
+ Simplified #line staments in the output make files more readable.
+ It now exits with value != 0 when errors occurr, which means
makefiles now stop when the *.d file has errors.
+ It accepts more flexible input as tokens. No need of [`] character,
use parenthesis instead; function names may contain packages
as in "si::unwind"
+ It does not generate #define/#undefine pragma, but uses variables
instead.
* Errors fixed:
+ #'mapcan and #'mapcon failed to handle dotted lists.
+ Inlined short-float/long-float values were truncated to ints.
+ declaim's effects are now visible at compile time.
+ proclaim causes no effect at compile time.
+ declarations cannot arise as the result of a macro expansion.
* CL package unpolluted:
+ 'system, '*break-enable* and others now rest in the 'system package.
+ function #'proclamation removed
* New macro expanders help the compiler to produce the right code for
(do ((s "asbc") c (i 0 (1+ i)))
((= i 3) c)
(declare (type character c))
(setq c (char s i)))
Formerly, C would be initialized with "char_code(Cnil)" which is
probably not what the user wanted.
* IN-PACKAGE is now a macro and DEFPACKAGE now expands to a shorter
expression with the help of an internal function SI:%DEFPACKAGE.
* Evaluation of (LAMBDA (..) ...) expressions now conses less when in
an empty lexical environment.
* The system now uses a different protocol for returning values.
+ If a lisp function returns one single value, the C function
outputs that value directly and sets NValues=1.
+ If N values are output, the function, sets NValues=N; it sets
VALUES(1..N-1) to the N-1 last values and outputs the first one.
* The code walker in PCL now avoids macroexpanding DOTIMES, DOLIST,
WHEN and UNLESS. This gives smaller/faster code in the interpreter.
ECLS 0.1a
=========
* Brand new interpreter based on a byte compiler. This implies major
changes to CLOS, the code walker and to the compiler.
* Export COMPILE-FILE-PATHNAME.
* Gabriel's benchmark incorporated to the source tree.
* Ported to NetBSD.
* Added support for SYMBOL-MACROLET in the interpreter.
* New lisp object for loaded binary files. This helps in garbage
collection of FASL objects and serves as a base for DLL support.
* Fixed documentation and doc/help.lsp.
* Fixed benchmark, which now output results in right order.
* SETF revised. Now it, and all accessors are implemented as macros
with no special support from the interpreter.
ECLS 0.1b
=========
* Due to human errors, the bytecompiler shipped with 0.1a was not the
finished version. In 0.1b we shipped a more polished files. Some of
the errors which are fixed are
+ Produce the right code for TAGBODY inside closures
+ Activate compiler for SYMBOL-MACROLET
+ Allow non-keyword symbols as lambda-list-keywords
+ Allow more than one :ALLOW-OTHER-KEYS to be supplied, but
discard other than the first one
+ Process declarations in FLET/LABELS forms
* Fixed the C compiler routines for TAGBODY: it would produce wrong
code when jumping out of a closure.
* Rewrite the error system using KMP's condition system, CLOS and a
rudimentary interface to the toplevel.
* Enclosing the bytecompiler in an UNWIND-PROTECT ensures that the
status of the compiler and of the interpreter is always consistent.
* Port and incorporate Peter Van Eynde's test suite for ANSI
compliance.
* Replace features ECL/ECL-MIN with ECLS and ECLS-MIN.
* Add simple-program-error and simple-control-error to the hierarchy
of conditions, and try to ensure that all routines in libecls.a
signal the right type of condition.
* Define COMPLEMENT and CONTINOUSLY.
* Fix #'= between bignums.
* NIL is no longer valid as the first of a pair of bounding index
designators, i.e. (nstring-upcase "aa" :start nil :end nil) causes
an error.
TODO:
=====
* Selectively remove spices from read.d and object.h
* Implement memory collection based on mmap()
* Improve the garbage collector using kernel information about dirty
pages.
* Improve fixnum_times.
* #'unread-char does not fail when the character differs from the
original one.
* vector-push-extend may succeed even if the vector is not
adjustable. Should we be more strict?
* should we relax ASSOC? (See lists156.tst)
* boost setf and generalized places -- the current implementation is
extremely faulty with respect to the standards.
* expand parse_namestring() to accept scaped strings, spaces, etc.
* fix FEerror* so that it accepts parameters.
* Remove most property lists from standard symbols.
;;; Local Variables: ***
;;; mode:text ***
;;; fill-column:70 ***
;;; End: ***

169
src/Makefile.in Normal file
View file

@ -0,0 +1,169 @@
#
# Makefile for ECoLisp
#
top_srcdir= @top_srcdir@
srcdir = @srcdir@
VPATH = @srcdir@
MACHINE = @MACHINE@
# Programs used by "make":
#
CC = @CC@
DEFS = -D$(MACHINE)
LIBS = @LIBS@ @TKLIBS@ @CLIBS@
CFLAGS = @CFLAGS@
LDFLAGS = @LDFLAGS@
#ifdef __GO32__
EXE = go32
#elif defined(__EMX__)
EXE = emx
#else
EXE =
#endif
SHELL = /bin/sh
RM = @RM@
# ==================== Where To Install Things ====================
# The default location for installation. Everything is placed in
# subdirectories of this directory. The default values for many of
# the variables below are expressed in terms of this one, so you may
# not need to change them. This defaults to /usr/local.
bindir=@bindir@
libdir=@libdir@
mandir=@mandir@
manext=.1
infodir=@infodir@
# Programs used by "make install":
#
INSTALL = @INSTALL@
INSTALL_PROGRAM = @INSTALL_PROGRAM@
INSTALL_DATA = @INSTALL_DATA@
# Files
SUBDIR = c gmp crs
LIBRARIES = libecls.a libcrs.a
TARGETS = ecls
#ifndef HAVE_LOCAL_GMP
LIBRARIES += libgmp.a
#endif
#ifdef GBC_BOEHM
SUBDIR += gc
LIBRARIES += libgc.a
#endif GBC_BOEHM
LSP_LIBRARIES = liblsp.a
#ifdef CLOS
LSP_LIBRARIES += libclos.a
#endif
#ifndef RUNTIME
LSP_LIBRARIES += libcmp.a
#endif
#ifdef CLX
TARGETS += eclx
LSP_LIBRARIES += libclx.a
#endif
# The makefiles of the directories in $SUBDIR.
# Don't split this line: configure does grep on it
SUBDIR_MAKEFILES= c/Makefile crs/Makefile tk/Makefile doc/Makefile gc/Makefile
all: $(TARGETS) doc
.PHONY: all
%Makefile: $(srcdir)/%Makefile.in config.status
./config.status
eclx: ecls compile_rest.lsp
./ecls < compile_rest.lsp
ecls: ecls_min compile.lsp
./ecls_min < compile.lsp
ecls_min: $(LIBRARIES) @RSYM@ .gdbinit
$(CC) $(LDFLAGS) -o $@ c/cinit.o -L./ $(LIBRARIES) $(LIBS)
test "@RSYM@" = "" || ./rsym ecls_min ecls_min.sym
.gdbinit: $(srcdir)/util/gdbinit
cp $(srcdir)/util/gdbinit $@
libecls.a:
cd c; $(MAKE)
libgc.a:
cd gc; $(MAKE)
libcrs.a @RSYM@:
cd crs; $(MAKE)
test "@RSYM@" = "" || cp crs/@RSYM@ .
libgmp.a:
cd gmp; $(MAKE); cp .libs/libgmp.a ..
BUILD-STAMP: config.status
(echo "#"; uname -a) > $@
head -8 config.status | tail -6 >> $@
install: BUILD-STAMP
for i in $(TARGETS); do $(INSTALL_PROGRAM) $$i $(PREFIX)$(bindir); strip $(PREFIX)$(bindir)/$$i; done
$(INSTALL_DATA) $(srcdir)/etc/ecls.1 $(PREFIX)$(mandir)
test -d $(PREFIX)$(libdir) || (mkdir $(PREFIX)$(libdir); chmod 755 $(PREFIX)$(libdir))
test -d $(PREFIX)$(libdir)/h || (mkdir $(PREFIX)$(libdir)/h; chmod 755 $(PREFIX)$(libdir)/h)
for i in $(TARGETS); do $(INSTALL_PROGRAM) $$i.sym $(PREFIX)$(libdir); done
$(INSTALL_DATA) BUILD-STAMP $(PREFIX)$(libdir)
$(INSTALL_DATA) h/config.h $(PREFIX)$(libdir)/h
#ifndef HAVE_LOCAL_GMP
$(INSTALL_DATA) gmp/?*.h $(PREFIX)$(libdir)/h
$(INSTALL_DATA) $(srcdir)/gmp/?*.h $(PREFIX)$(libdir)/h
#endif
for i in $(LSP_LIBRARIES) $(LIBRARIES); do \
$(INSTALL_DATA) $$i $(PREFIX)$(libdir); \
done
#ifdef GBC_BOEHM
for i in $(srcdir)/gc/include/?*.h; do $(INSTALL_DATA) $$i $(PREFIX)$(libdir)/h/`basename $$i`; done
test -d $(PREFIX)$(libdir)/h/private || (mkdir $(PREFIX)$(libdir)/h/private; chmod 755 $(PREFIX)$(libdir)/h/private)
for i in $(srcdir)/gc/include/private/?*.h; do $(INSTALL_DATA) $$i $(PREFIX)$(libdir)/h/private/`basename $$i`; done
#endif GBC_BOEHM
test "@RSYM@" = "" || $(INSTALL_PROGRAM) @RSYM@ $(PREFIX)$(libdir)
cd c; $(MAKE) PREFIX="$(PREFIX)" install
cd doc; $(MAKE) PREFIX="$(PREFIX)" install
uninstall:
rm -rf $(mandir)/ecls.1
rm -rf $(bindir)/ecls
rm -rf $(libdir)
cd doc; $(MAKE) uninstall
doc: $(TARGETS)
cd doc; $(MAKE)
clean: clean_lisp
for i in ${SUBDIR}; do (cd $$i; make clean); done
$(RM) ecls_min ecls_min.sym ecls ecls.sym help.doc core a.out
$(RM) config.version config.log config.cache
$(RM) *.c *.o *.a *.h *.data
clean_lisp:
for i in lsp cmp clos clx tk; do rm -f lib$$i.a $$i/?*.o $$i/?*.c $$i/?*.data $$i/?*.h; done
distclean: clean
realclean: distclean
test1:
cd c; make
make ecls_min
make ecls
cd tests; make
diff tests tests2
test2:
make clean_lisp
cd c; make
make ecls_min
$(RM) ecls
make ecls
for i in lsp clos cmp; do diff --exclude=\*.o $$i old/$$i; done
test3:
-mkdir stage2
cp -rf lsp clos cmp stage2
-for i in lsp cmp clos clx tk; do test -f lib$$i.a && mv lib$$i.a stage2; done
make clean_lisp
./ecls < compile2.lsp
for i in lsp clos cmp clx tk; do test -d $$i && diff --exclude=\*.o $$i stage2/$$i; done

340
src/ansi-tests/GNU-GPL Normal file
View file

@ -0,0 +1,340 @@
GNU GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1989, 1991 Free Software Foundation, Inc.
59 Temple Place - Suite 330, Boston, MA 02111-1307,
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., 59 Temple Place - Suite 330, Boston, MA 02111-1307, 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.

29
src/ansi-tests/Makefile.in Normal file
View file

@ -0,0 +1,29 @@
top_srcdir=@top_srcdir@
srcdir=@srcdir@
RM=rm -fr
MV=mv -f
MKDIR=mkdir -p
.PHONY: clisp sbcl normal safe ecls ecls_min
ecls:
ln -sf ../../src/h/*.h ../h/
(echo '(load "$(srcdir)/tests")'; \
echo '(setq si::*system-directory* "../")'; \
echo "(run-all-tests \"$(srcdir)/\")"; \
echo "(quit)") | ../ecls
true
ecls_min:
ln -sf ../../src/h/*.h ../h/
(echo '(load "bare.lsp")'; \
echo '(setq si::*system-directory* "../")'; \
echo '(sys::chdir "ansi-tests")'; \
echo '(load "$(srcdir)/tests")'; \
echo "(run-all-tests \"$(srcdir)/\")"; \
echo "(quit)") | (cd ..; ./ecls_min)
true
clean:
$(RM) *.erg *.o *.c *.h *.data

28
src/ansi-tests/README Normal file
View file

@ -0,0 +1,28 @@
This is a bunch of tests to test if a Common Lisp implementation
conforms to Ansi standard X3J13 for Common Lisp.
It is largely based on the clisp test-suite, examples from the HyperSpec and
bugreports.
This is a work in progress.
Even though it's in the clocc package, the ansi-tests system
is a standalone system. It can run without having anything else
from clocc available; all you need is the ansi-test/ directory.
There is a Makefile that should sort-of-work, please look at it
and adapt it to your situation.
To run the tests manually, start your Lisp in the ansi-test/
directory and type
(load "tests.lisp")
at the command prompt.
The tests produce output on the console, with failed tests
marked with "ERROR!!". They also produce error output files
with extensions ".erg", where every entry in such a file
is from a failed test. Thus, if ansi-test thinks your Lisp
is compliant, it will still produce a lot of output on the
console, but no "ERROR!!" messages; and it will produce
only empty ".erg" files (that should get deleted away).

3309
src/ansi-tests/alltest.lisp Normal file
View file

File diff suppressed because it is too large Load diff

1006
src/ansi-tests/array.lisp Normal file
View file

File diff suppressed because it is too large Load diff

34
src/ansi-tests/backquot.lisp Normal file
View file

@ -0,0 +1,34 @@
;;; Based on 1.1.1.1 -*- mode: lisp -*-
;;; testen von backquote
(in-package :cl-user)
(my-assert
(setf x (list 'a 'b 'c))
(a b c))
(my-assert
`(x ,x ,@x foo ,(cadr x) bar ,(cdr x) baz ,@(cdr x) ,. x)
(X (A B C) A B C FOO B BAR (B C) BAZ B C A B C))
(my-assert
(read-from-string "`,@x")
ERROR)
(my-assert
`(,x . ,x) ; = (append (list x) x)
((a b c) a b c))
(my-assert
(read-from-string "`(,x . ,@x)")
ERROR)
(my-assert
(read-from-string ",x")
ERROR)
(my-assert
`#(1 2 3 4)
#(1 2 3 4))

894
src/ansi-tests/characters.lisp Normal file
View file

@ -0,0 +1,894 @@
;;; based on v1.4 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
char-code-limit
#+xcl 128
#+(or (and clisp (not unicode)) akcl sbcl cmu ecls) 256
#+(or (and clisp unicode) allegro) 65536
#-(or xcl clisp akcl allegro cmu sbcl ecls) unknown)
(my-assert
(standard-char-p #\a)
t)
(my-assert
(standard-char-p #\$)
t)
(my-assert
(standard-char-p #\.)
t)
(my-assert
(standard-char-p #\A)
t)
(my-assert
(standard-char-p 1)
type-error)
(my-assert
(standard-char-p #\\)
t)
(my-assert
(standard-char-p #\5)
t)
(my-assert
(standard-char-p #\))
t)
(my-assert
(standard-char-p #\%)
t)
(my-assert
(standard-char-p #\Backspace)
#+xcl t
#-xcl nil)
(my-assert
(standard-char-p #\Page)
#+xcl t
#-xcl nil)
(my-assert
(standard-char-p #\Return)
#+xcl t
#-xcl nil)
(my-assert
(graphic-char-p #\a)
t)
(my-assert
(graphic-char-p #\$)
t)
(my-assert
(graphic-char-p #\.)
t)
(my-assert
(graphic-char-p #\A)
t)
(my-assert
(graphic-char-p 1)
type-error)
(my-assert
(graphic-char-p #\\)
t)
(my-assert
(graphic-char-p #\5)
t)
(my-assert
(graphic-char-p #\))
t)
(my-assert
(graphic-char-p #\%)
t)
(my-assert
(graphic-char-p #\Backspace)
nil)
(my-assert
(graphic-char-p #\Page)
nil)
(my-assert
(graphic-char-p #\Return)
nil)
(my-assert
(characterp
#\a)
t)
(my-assert
(characterp
#\$)
t)
(my-assert
(characterp
#\.)
t)
(my-assert
(characterp
#\A)
t)
(my-assert
(characterp
#\\)
t)
(my-assert
(characterp
#\5)
t)
(my-assert
(characterp
#\))
t)
(my-assert
(characterp
#\%)
t)
(my-assert
(characterp
#\Backspace)
t)
(my-assert
(characterp
#\Page)
t)
(my-assert
(characterp
#\Return)
t)
(my-assert
(alpha-char-p #\a)
t)
(my-assert
(alpha-char-p #\$)
nil)
(my-assert
(alpha-char-p #\.)
nil)
(my-assert
(alpha-char-p #\A)
t)
(my-assert
(alpha-char-p 1)
type-error)
(my-assert
(alpha-char-p #\\)
nil)
(my-assert
(alpha-char-p #\5)
nil)
(my-assert
(alpha-char-p #\))
nil)
(my-assert
(alpha-char-p #\%)
nil)
(my-assert
(alpha-char-p #\Backspace)
nil)
(my-assert
(alpha-char-p #\Page)
nil)
(my-assert
(alpha-char-p #\Return)
nil)
(my-assert
(upper-case-p #\a)
nil)
(my-assert
(upper-case-p #\$)
nil)
(my-assert
(upper-case-p #\.)
nil)
(my-assert
(upper-case-p #\A)
t)
(my-assert
(upper-case-p 1)
type-error)
(my-assert
(upper-case-p #\\)
nil)
(my-assert
(upper-case-p #\5)
nil)
(my-assert
(upper-case-p #\))
nil)
(my-assert
(upper-case-p #\%)
nil)
(my-assert
(upper-case-p #\Backspace)
nil)
(my-assert
(upper-case-p #\Page)
nil)
(my-assert
(upper-case-p #\Return)
nil)
(my-assert
(lower-case-p #\a)
t)
(my-assert
(lower-case-p #\$)
nil)
(my-assert
(lower-case-p #\.)
nil)
(my-assert
(lower-case-p #\A)
nil)
(my-assert
(lower-case-p 1)
type-error)
(my-assert
(lower-case-p #\\)
nil)
(my-assert
(lower-case-p #\5)
nil)
(my-assert
(lower-case-p #\))
nil)
(my-assert
(lower-case-p #\%)
nil)
(my-assert
(lower-case-p #\Backspace)
nil)
(my-assert
(lower-case-p #\Page)
nil)
(my-assert
(lower-case-p #\Return)
nil)
(my-assert
(both-case-p #\a)
t)
(my-assert
(both-case-p #\$)
nil)
(my-assert
(both-case-p #\.)
nil)
(my-assert
(both-case-p #\A)
t)
(my-assert
(both-case-p 1)
type-error)
(my-assert
(both-case-p #\\)
nil)
(my-assert
(both-case-p #\5)
nil)
(my-assert
(both-case-p #\))
nil)
(my-assert
(both-case-p #\%)
nil)
(my-assert
(both-case-p #\Backspace)
nil)
(my-assert
(both-case-p #\Page)
nil)
(my-assert
(both-case-p #\Return)
nil)
(my-assert
(digit-char-p #\a)
nil)
(my-assert
(digit-char-p #\$)
nil)
(my-assert
(digit-char-p #\.)
nil)
(my-assert
(digit-char-p #\A)
nil)
(my-assert
(digit-char-p 1)
type-error)
(my-assert
(digit-char-p #\\)
nil)
(my-assert
(digit-char-p #\5)
5)
(my-assert
(digit-char-p #\))
nil)
(my-assert
(digit-char-p #\%)
nil)
(my-assert
(digit-char-p #\Backspace)
nil)
(my-assert
(digit-char-p #\Page)
nil)
(my-assert
(digit-char-p #\Return)
nil)
(my-assert
(digit-char-p #\5 4)
nil)
(my-assert
(digit-char-p #\5 8)
5)
(my-assert
(digit-char-p #\E 16)
14)
(my-assert
(digit-char-p #\R 35)
27)
(my-assert
(digit-char-p #\5 4)
nil)
(my-assert
(digit-char-p #\5 5)
nil)
(my-assert
(digit-char-p #\5 6)
5)
(my-assert
(digit-char-p #\1 2)
1)
(my-assert
(alphanumericp #\a)
t)
(my-assert
(alphanumericp #\$)
nil)
(my-assert
(alphanumericp #\.)
nil)
(my-assert
(alphanumericp #\A)
t)
(my-assert
(alphanumericp 1)
type-error)
(my-assert
(alphanumericp #\\)
nil)
(my-assert
(alphanumericp #\5)
t)
(my-assert
(alphanumericp #\))
nil)
(my-assert
(alphanumericp #\%)
nil)
(my-assert
(alphanumericp #\Backspace)
nil)
(my-assert
(alphanumericp #\Page)
nil)
(my-assert
(alphanumericp #\Return)
nil)
(my-assert
(alphanumericp #\5 4)
error)
(my-assert
(alphanumericp #\5 8)
error)
(my-assert
(alphanumericp #\E 16)
error)
(my-assert
(alphanumericp #\R 35)
error)
(my-assert
(char= #\d #\d)
t)
(my-assert
(char/= #\d #\d)
nil)
(my-assert
(char= #\d #\x)
nil)
(my-assert
(char/= #\d #\x)
t)
(my-assert
(char= #\d #\D)
nil)
(my-assert
(char/= #\d #\D)
t)
(my-assert
(char= #\d #\d #\d #\d)
t)
(my-assert
(char/= #\d #\d #\d #\d)
nil)
(my-assert
(char= #\d #\d #\x #\d)
nil)
(my-assert
(char/= #\d #\d #\x #\d)
nil)
(my-assert
(char= #\d #\y #\x #\c)
nil)
(my-assert
(char/= #\d #\y #\x #\c)
t)
(my-assert
(char= #\d #\c #\d)
nil)
(my-assert
(char/= #\d #\c #\d)
nil)
(my-assert
(char< #\d #\x)
t)
(my-assert
(char<= #\d #\x)
t)
(my-assert
(char< #\d #\d)
nil)
(my-assert
(char<= #\d #\d)
t)
(my-assert
(char< #\a #\e #\y #\z)
t)
(my-assert
(char<= #\a #\e #\y #\z)
t)
(my-assert
(char< #\a #\e #\e #\y)
nil)
(my-assert
(char<= #\a #\e #\e #\y)
t)
(my-assert
(char> #\e #\d)
t)
(my-assert
(char>= #\e #\d)
t)
(my-assert
(char> #\d #\c #\b #\a)
t)
(my-assert
(char>= #\d #\c #\b #\a)
t)
(my-assert
(char> #\d #\d #\b #\a)
nil)
(my-assert
(char>= #\d #\d #\b #\a)
t)
(my-assert
(char> #\e #\d #\b #\c #\a)
nil)
(my-assert
(char>= #\e #\d #\b #\c #\a)
nil)
(my-assert
(char> #\z #\A)
t)
(my-assert
(char> #\Z #\a)
nil)
(my-assert
(char< #\9 #\a)
t)
(my-assert
(char> #\9 #\a)
nil)
(my-assert
(char> #\z #\0)
t)
(my-assert
(char< #\z #\0)
nil)
(my-assert
(char-equal #\d #\d)
t)
(my-assert
(char-not-equal #\d #\d)
nil)
(my-assert
(char-equal #\d #\x)
nil)
(my-assert
(char-not-equal #\d #\x)
t)
(my-assert
(char-equal #\d #\D)
t)
(my-assert
(char-not-equal #\d #\D)
nil)
(my-assert
(char-equal #\d #\d #\d #\d)
t)
(my-assert
(char-not-equal #\d #\d #\d #\d)
nil)
(my-assert
(char-equal #\d #\d #\x #\d)
nil)
(my-assert
(char-not-equal #\d #\d #\x #\d)
nil)
(my-assert
(char-equal #\d #\y #\x #\c)
nil)
(my-assert
(char-not-equal #\d #\y #\x #\c)
t)
(my-assert
(char-equal #\d #\c #\d)
nil)
(my-assert
(char-not-equal #\d #\c #\d)
nil)
(my-assert
(char-lessp #\d #\x)
t)
(my-assert
(char-not-greaterp #\d #\x)
t)
(my-assert
(char-lessp #\d #\d)
nil)
(my-assert
(char-not-greaterp #\d #\d)
t)
(my-assert
(char-lessp #\a #\e #\y #\z)
t)
(my-assert
(char-not-greaterp #\a #\e #\y #\z)
t)
(my-assert
(char-lessp #\a #\e #\e #\y)
nil)
(my-assert
(char-not-greaterp #\a #\e #\e #\y)
t)
(my-assert
(char-greaterp #\e #\d)
t)
(my-assert
(char-not-lessp #\e #\d)
t)
(my-assert
(char-greaterp #\d #\c #\b #\a)
t)
(my-assert
(char-not-lessp #\d #\c #\b #\a)
t)
(my-assert
(char-greaterp #\d #\d #\b #\a)
nil)
(my-assert
(char-not-lessp #\d #\d #\b #\a)
t)
(my-assert
(char-greaterp #\e #\d #\b #\c #\a)
nil)
(my-assert
(char-not-lessp #\e #\d #\b #\c #\a)
nil)
(my-assert
(char-greaterp #\z #\A)
t)
(my-assert
(char-greaterp #\Z #\a)
t)
(my-assert
(char-lessp #\9 #\a)
t)
(my-assert
(char-greaterp #\9 #\a)
nil)
(my-assert
(char-greaterp #\z #\0)
t)
(my-assert
(char-lessp #\z #\0)
nil)
(my-assert
(char-equal #\A #\a)
t)
(my-assert
(char-upcase #\a)
#\A)
(my-assert
(char-upcase #\A)
#\A)
(my-assert
(char-upcase #\5)
#\5)
(my-assert
(char-upcase #\;)
#\;)
(my-assert
(char-upcase #\=)
#\=)
(my-assert
(char= (char-downcase (char-upcase #\x)) #\x)
t)
(my-assert
(char-downcase #\A)
#\a)
(my-assert
(char-downcase #\a)
#\a)
(my-assert
(char-downcase #\%)
#\%)
(my-assert
(char-downcase #\+)
#\+)
(my-assert
(char-downcase #\-)
#\-)
(my-assert
(char= (char-upcase (char-downcase #\X)) #\X)
t)
(my-assert
(digit-char 7)
#\7)
(my-assert
(digit-char 12)
nil)
(my-assert
(digit-char 'a)
error)
(my-assert
(digit-char 12 16)
#\C)
(my-assert
(digit-char 6 2)
nil)
(my-assert
(digit-char 1 2)
#\1)
;; evan though char-*-bit are not in the ANSI CL standard,
;; they may be present as an extension
;; (my-assert
;; char-control-bit
;; error)
;; (my-assert
;; char-meta-bit
;; error)
;; (my-assert
;; char-super-bit
;; error)
;; (my-assert
;; char-hyper-bit
;; error)
(my-assert
(char-name #\Space)
"Space")
(my-assert
(char-name #\Newline)
#-cmu
"Newline"
#+cmu
"Linefeed")

468
src/ansi-tests/clos.lisp Normal file
View file

@ -0,0 +1,468 @@
;;; based on v1.2 -*- mode: lisp -*-
(in-package :cl-user)
#-(OR CMU SBCL)
(my-assert
(use-package "CLOS")
T)
#+SBCL
(my-assert
(use-package "SB-PCL")
T)
(my-assert
(unintern '<C1>)
T)
(my-assert
(progn
(defclass <C1> ()
((x :initform 0 :accessor x-val :reader get-x :writer set-x :initarg :x)
(y :initform 1 :accessor y-val :reader get-y :writer set-y :initarg :y)))
())
NIL)
(my-assert
(progn
(defclass <C2> (<C1>)
((z :initform 0 :accessor z-val :reader get-z :writer set-z :initarg :z)))
())
NIL)
(my-assert
(defparameter a (make-instance (find-class '<C1>) :x 10))
A)
(my-assert
(x-val a)
10)
(my-assert
(y-val a)
1)
(my-assert
(setf (x-val a) 20)
20)
(my-assert
(x-val a)
20)
(my-assert
(get-x a)
20)
(my-assert
(set-x 10 a)
10)
(my-assert
(x-val a)
10)
(my-assert
(defparameter b (make-instance (find-class '<C2>) :x 10 :y 20 :z 30))
B)
(my-assert
(x-val b)
10)
(my-assert
(y-val b)
20)
(my-assert
(z-val b)
30)
(my-assert
(progn
(defgeneric f (x y)
(:method ((x t) (y t))
(list x y)))
(defmethod f ((i integer) (j number))
(+ i j))
(defmethod f ((s1 string) (s2 string))
(concatenate 'string s1 s2))
())
NIL)
(my-assert
(f t t)
(T T))
(my-assert
(f 2 3)
5)
(my-assert
(f 2 3.0)
5.0)
(my-assert
(f 2.0 3)
(2.0 3))
(my-assert
(f "ab" "cd")
"abcd")
(my-assert
(f 1 "abc")
(1 "abc"))
(my-assert
(progn
(defgeneric f (x y)
(:method ((x t) (y t))
(list x y))
(:method ((i number) (j integer))
(list (call-next-method) (- i j)))
(:method ((i integer) (j number))
(list (call-next-method) (+ i j))))
())
NIL)
(my-assert
(f 'x 'y)
(X Y))
(my-assert
(f 1 2)
(((1 2) -1) 3))
(my-assert
(f 1 2.0)
((1 2.0) 3.0))
(my-assert
(f 1.0 2)
((1.0 2) -1.0))
(my-assert
(progn
(defgeneric g (x)
(:method ((x null))
(cons 'null (call-next-method)))
(:method ((x list))
(if (next-method-p)
(cons 'list (call-next-method))
'(list$)))
(:method ((x symbol))
(if (next-method-p)
(cons 'symbol (call-next-method))
'(symbol$))))
())
NIL)
(my-assert
(g 'x)
(SYMBOL$))
(my-assert
(g '(x))
(LIST$))
(my-assert
(g '())
(NULL SYMBOL LIST$)
"Class precedence list for NULL:
null, symbol, list, sequence, t")
(my-assert
(defvar hl)
HL)
(my-assert
(progn
(defgeneric hgen (x)
(:method ((x integer))
(setf hl (cons 'i-primary-1 hl))
(call-next-method)
(setf hl (cons 'i-primary-2 hl)))
(:method :before ((x integer))
(setf hl (cons 'i-before hl)))
(:method :after ((x integer))
(setf hl (cons 'i-after hl)))
(:method :around ((x integer))
(setf hl (cons 'i-around-1 hl))
(call-next-method)
(setf hl (cons 'i-around-2 hl)))
(:method ((x number))
(setf hl (cons 'n-primary-1 hl))
(call-next-method)
(setf hl (cons 'n-primary-2 hl)))
(:method :before ((x number))
(setf hl (cons 'n-before hl)))
(:method :after ((x number))
(setf hl (cons 'n-after hl)))
(:method :around ((x number))
(setf hl (cons 'n-around-1 hl))
(call-next-method)
(setf hl (cons 'n-around-2 hl)))
(:method ((x t))
(setf hl (cons 'innermost hl))))
(defun h (x)
(setf hl '()) (hgen x) (reverse hl))
)
H)
(my-assert
(h 'abc)
(INNERMOST))
(my-assert
(h 3.14)
(N-AROUND-1 N-BEFORE N-PRIMARY-1 INNERMOST N-PRIMARY-2 N-AFTER N-AROUND-2))
(my-assert
(h 3)
(I-AROUND-1 N-AROUND-1 I-BEFORE N-BEFORE I-PRIMARY-1 N-PRIMARY-1 INNERMOST
N-PRIMARY-2 I-PRIMARY-2 N-AFTER I-AFTER N-AROUND-2 I-AROUND-2
))
(my-assert
(unintern '<C1>)
T)
(my-assert
(progn
(defclass <C1> ()
((x :initform 0 :accessor x-val :initarg :x)
(y :initform 1 :accessor y-val :initarg :y)))
())
NIL)
(my-assert
(defparameter a (make-instance (find-class '<C1>) :x 10))
A)
(my-assert
(defparameter b (make-instance (find-class '<C1>) :y 20 :x 10))
B)
(my-assert
(defparameter c (make-instance (find-class '<C1>)))
C)
(my-assert
(x-val a)
10)
(my-assert
(y-val a)
1)
(my-assert
(x-val b)
10)
(my-assert
(y-val b)
20)
(my-assert
(x-val c)
0)
(my-assert
(y-val c)
1)
(my-assert
(unintern '<C1>)
T)
(my-assert
(progn
(defclass <C1> ()
((x :initform 0 :accessor x-val :initarg :x)
(y :initform 1 :accessor y-val :initarg :y)))
(defmethod initialize-instance :after ((instance <C1>) &rest initvalues)
(if (= (x-val instance) 0)
(setf (x-val instance) (y-val instance))))
())
NIL)
(my-assert
(x-val (make-instance (find-class '<C1>)))
1)
(my-assert
(x-val (make-instance (find-class '<C1>) :x 10))
10)
(my-assert
(x-val (make-instance (find-class '<C1>) :y 20))
20)
(my-assert
(x-val (make-instance (find-class '<C1>) :x 10 :y 20))
10)
(my-assert
(unintern '<C1>)
T)
(my-assert
(eq (class-of ()) (find-class 'null))
T)
(my-assert
(eq (class-of t) (find-class 'symbol))
T)
(my-assert
(eq (class-of 10)
(find-class #+(or ALLEGRO cmu sbcl) 'fixnum
#-(or ALLEGRO cmu sbcl) 'integer))
T)
(my-assert
(eq (class-of 10.0)
(find-class #+(or ALLEGRO cmu sbcl) 'single-float
#-(or ALLEGRO cmu sbcl) 'float))
T)
(my-assert
(eq (class-of '(a b))
(find-class 'cons))
T)
(my-assert
(eq (class-of "abc")
(find-class #+(OR CMU SBCL) 'simple-string
#-(OR CMU SBCL) 'string))
T)
(my-assert
(eq (class-of '#(1 2))
(find-class #+(OR CMU SBCL) 'simple-vector
#-(OR CMU SBCL) 'vector))
T)
(my-assert
(eq (class-of #'car)
(find-class 'function))
T)
(my-assert
(eq (class-of #'make-instance)
(find-class 'standard-generic-function))
T)
(my-assert
(eq (class-of '#2a((a) (b)))
(find-class #+(OR CMU SBCL) 'simple-array
#-(OR CMU SBCL) 'array))
T)
(my-assert
(eq (class-of *standard-input*)
(find-class 'stream))
NIL)
(my-assert
(eq (class-of (lambda (x) x))
(find-class 'function))
T
"lambda should return a function.
a function is:
function n. 1. an object representing code, which can
be called with zero or more arguments, and which produces
zero or more values. 2. an object of type function.
So class-of should return a function. Not?")
(my-assert
(eq (class-of (find-class 't))
(find-class 'built-in-class))
T)
(my-assert
(typep "abc" (find-class 't))
T)
(my-assert
(typep "abc" (find-class 'array))
T)
(my-assert
(typep "abc" (find-class 'vector))
T)
(my-assert
(typep "abc" (find-class 'string))
T)
(my-assert
(typep "abc" (find-class 'integer))
NIL)
(my-assert
(typep 3 (find-class 't))
T)
(my-assert
(typep 3 (find-class 'number))
T)
(my-assert
(typep 3 (find-class 'float))
NIL)
(my-assert
(typep 3 (find-class 'integer))
T)
(my-assert
(typep 3 (find-class 'string))
NIL)
(my-assert
(typep *standard-input* (find-class 'stream))
T)
#+(or clisp allegro cmu sbcl)
(my-assert
#+CLISP
(defun subclassp (class1 class2)
(clos::subclassp class1 class2)
)
#+ALLEGRO
(defun subclassp (class1 class2)
(finalize-inheritance class1)
(not (null (member class2 (class-precedence-list class1))))
)
#+CMU
(defun subclassp (class1 class2)
(not (null (member (car (pcl:class-precedence-list class2))
(pcl:class-precedence-list class1)
) ) ) )
#+sbcl
(defun subclassp (class1 class2)
(not (null (member (car (sb-pcl:class-precedence-list class2))
(sb-pcl:class-precedence-list class1)
) ) ) )
#+(or CLISP ALLEGRO cmu sbcl) SUBCLASSP)
(my-assert
(subclassp (find-class 'number)
(find-class 't))
T)
(my-assert
(subclassp (find-class 'integer)
(find-class 'number))
T)
(my-assert
(subclassp (find-class 'float)
(find-class 'number))
T)

640
src/ansi-tests/cmucl-bugs.lisp Normal file
View file

@ -0,0 +1,640 @@
;;; -*- mode: lisp -*-
(in-package :cl-user)
;; Your fd-stream-read-n-bytes (in 17e) crashes when reading from a
;; pipe and it didn't get the requested byte-count (it should re-read
;; because pipe-reads may be interrupted). You have done some changes
;; in from 17c to 17e (I think) but it dosen't work yet. Here is a old
;; patched version that works for us.
;;An alist with SETF and a function name causes
;;an error whenever it's used:
(my-assert
(defparameter foo '((setf . sqrt)))
FOO)
(my-assert
foo
((SETF . SQRT)))
(my-assert
(setq foo '((zut . 4)))
((ZUT . 4)))
(my-assert
foo
((ZUT . 4)))
(my-assert
(setq foo '((setf . 3)))
((SETF . 3)))
(my-assert
'(setq . 2)
(setq . 2))
(unintern 'foo)
;;
(my-assert
(* 10000000000000000000000000000000000000000
10000000000000000000000000000000000000000)
100000000000000000000000000000000000000000000000000000000000000000000000000000000)
(my-assert
(time (+ 2 2))
4)
;; cltl2 p 727
(my-assert
(let ((stack (copy-list '(a b c d e f))))
(loop for item = (length stack) then (pop stack) while stack
collect item))
(6 A B C D E))
;; p 737
(my-assert
(loop with ( a b c) (float integer float)
return (list a b c))
(0.0 0 0.0))
(my-assert
(loop with ( a b c) float
return (list a b c))
(0.0 0.0 0.0))
;; printing arrays
(my-assert
(make-array '(22) :element-type 'single-float :initial-element 0.0)
#(0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0))
(my-assert
(make-array '(2 2))
#-clisp
#2A((0 0) (0 0))
#+clisp
#2A((NIL NIL) (NIL NIL)))
(my-assert
(make-array '(2 2) :element-type 'single-float :initial-element 0.0)
#2A((0.0 0.0) (0.0 0.0)))
;; without pretty-print?
(my-assert
(make-array '(22) :element-type 'single-float :initial-element 0.0)
#(0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0))
(my-assert
(make-array '(2 2))
#-clisp
#2A((0 0) (0 0))
#+clisp
#2A((NIL NIL) (NIL NIL)))
(my-assert
(make-array '(2 2) :element-type 'single-float :initial-element 0.0)
#2A((0.0 0.0) (0.0 0.0)))
;; bignums
(my-assert
(defun factorial (n &optional (i 1))
(if (plusp n) (factorial (1- n) (* i n)) i))
FACTORIAL)
(my-assert
(/ (factorial 100) (factorial 99))
100)
(my-assert
(/ (factorial 1000) (factorial 999))
1000)
(unintern 'factorial)
(my-assert
1e-37
10.0e-38)
(my-assert
1L-38
10.0L-39)
(my-assert
(flet ((print-result (x)
(format nil "~&x is ~F (a ~S)." x (type-of x))))
(print-result "non-number"))
"x is non-number (a (SIMPLE-BASE-STRING 10))."
"Notice that ~3,2F does work.")
(my-assert
(defun sigmoid (x)
(/ 1 (1+ (exp (- x)))))
SIGMOID)
(my-assert
(compile 'sigmoid) ; in CMU Common Lisp 17f
SIGMOID)
#-clisp
(my-assert
(sigmoid 100)
1.0)
(unintern 'sigmoid)
(my-assert
(setq X (copy-list '((1 2) (1 2 3) (3))))
((1 2) (1 2 3) (3)))
(my-assert
(remove-duplicates X :test #'subsetp)
((1 2 3) (3)))
(my-assert
(delete-duplicates X :test #'subsetp)
((1 2 3) (3)))
(unintern 'X)
(my-assert
(progn
(run-program "/bin/date" '() :output t :error :stream)
t)
t)
;; #<process 780 :EXITED>
(my-assert
(- 0.0 #C( 1.0 1.0))
#C(-1.0 -1.0))
(my-assert
(- #C(.5 .866) 0.0)
#C(0.5 0.866))
(my-assert
(/ 2.0 #C(-1.0 -1.0))
#C(-1.0 1.0))
(my-assert
(* 2.0 #C(-1.0 -1.0))
#C(-2.0 -2.0))
(my-assert
(with-open-file
(foo "/tmp/foocl"
:direction :output
:element-type
(list 'signed-byte (1+ (integer-length
most-positive-fixnum))))
(write-byte 17 foo)
(write-byte -17 foo)
(write-byte 4517 foo)
(write-byte -1217 foo))
-1217)
(my-assert
(with-open-file
(foo "/tmp/foocl"
:direction :input
:element-type
(list 'signed-byte (1+ (integer-length
most-positive-fixnum))))
(list (read-byte foo)
(read-byte foo)
(read-byte foo)
(read-byte foo)))
(17 -17 4517 -1217))
(my-assert
(unless (ignore-errors (error "grr"))
(print "hi"))
"hi")
(my-assert
(setf (elt '(a b c d) 2) 'x)
x)
(my-assert
(acos 1.00001)
#+(or cmu sbcl)
#C(0.0 0.004475168)
#+clisp
#C(0 0.0044751023)
#-(or clisp cmu sbcl)
fill-this-in)
(my-assert
(parse-namestring (make-pathname :defaults "tst"))
#p"tst")
(my-assert
(string< "abcd" "012abcz" :start2 3 :end2 6)
NIL)
(my-assert
(string> "abcd" "012abcd" :start2 3 :end2 5)
2)
(my-assert
(defun (setf foo) () t)
(setf foo))
(my-assert
(compile '(setf foo))
(setf foo))
(my-assert
(typep '(setf cons)
'generic-function)
NIL)
(my-assert
(make-sequence '(vector float) 4 :initial-element 0.0)
#(0.0 0.0 0.0 0.0))
(my-assert
(typep (complex 0.0d0) '(complex double-float))
t
"complex returns a number whose real part is realpart
and whose imaginary part is imagpart.
If realpart is a rational and imagpart is the rational
number zero, the result of complex is realpart, a rational.
Otherwise, the result is a complex.
If either realpart or imagpart is a float, the non-float
is converted to a float before the complex is created. If
imagpart is not supplied, the imaginary part is a zero of
the same type as realpart; i.e., (coerce 0 (type-of
realpart)) is effectively used.
the second parameter is not supplied, the first is
a double-float, so actually this is (complex 0.0d0 0.0d0)
these are not rationals, so we get a complex number back.
")
;; From: Gary Bunting <gbunting@cantor.une.edu.au>
(my-assert
(setf xx (expt 3 32))
1853020188851841)
(my-assert
(* xx xx)
3433683820292512484657849089281)
#| ;
(defun bugged (x)
(labels ((f (y &optional trouble) ; <<< or &key or &rest ..
(if y
(let ((a (pop y)))
(f a)))))
;;;; (f x) <<<
;;;; Error in function COMMON-LISP::ASSERT-ERROR:
;;;; The assertion (EQ (C::LAMBDA-TAIL-SET C::CALLER)
;;;; (C::LAMBDA-TAIL-SET (C::LAMBDA-HOME C::CALLEE)))
;;;; failed.
;;; However this works ok.
(f x nil)))
|#
(my-assert
(defun bugged (x)
(labels ((f (y &optional trouble) ; <<< or &key or &rest ..
(if y
(let ((a (pop y)))
(f a)))))
(f x)))
BUGGED)
(my-assert
(bugged (list (list)))
NIL)
(unintern 'bugged)
(my-assert
(defun tst()
(with-open-file
(stream "does-not-exist" :if-does-not-exist nil)
(unless stream
'abacab)))
TST)
(my-assert
(tst)
abacab)
(unintern 'tst)
(my-assert
(defun f (a b)
(declare (type (single-float 0.0 0.5) a)
(type (single-float 0.0 0.2) b)
(optimize (debug 0) (safety 0) (speed 3)))
(expt a b))
F)
(my-assert
(progn
(compile 'f)
t)
t)
;;; deltax^2 == deltat
;;; from Paul Werkowski
(my-assert
(progn
(compile-file "compile-bug5.lisp")
:ok)
:ok)
(my-assert
(progn
(compile-file "compile-bug6.lisp")
:ok)
:ok)
(my-assert
(progn
(defclass cl1 ()())
(defclass cl2 (cl1 missing)())
(defclass cl4 ()())
(defmethod foo ((c cl2))
c)
;; method specializing on class with fwd reference
;; ok so far
;; then this dies
(defmethod foo ((c cl4))
c) ;; add a new method to gf #'foo
t)
T)
(my-assert
(progn
(defmethod foo ((f function))
f)
(defun zzz (x)
x)
(foo #'zzz) ;; this is supposed to work.
t)
t)
(unintern 'zzz)
#+(or sbcl cmu)
(my-assert
(progn
(compile-file "compile-bug1.lisp")
:ok)
:ok)
;;; From: William Harold Newman <william.newman@airmail.net>
(my-assert
(equalp #\a 'a)
nil)
(defun my-sxhash (x)
(declare (type double-float x))
(sxhash x))
(my-assert
(eq (my-sxhash 1.2d0)
(sxhash 1.2d0))
T)
(my-assert
(progn
(compile 'my-sxhash)
(eq (my-sxhash 1.2d0)
(sxhash 1.2d0)))
T)
;;; From: Raymond Toy <toy@rtp.ericsson.se>
(defun tst2 (x n)
(declare (type (integer -134217728 134217728) x)
(type (integer -4 4) n)
(optimize (speed 3) (safety 0)))
(ash x n))
(my-assert
(compile 'tst2)
tst2)
;; From pvaneynd:
(my-assert
(exp 1)
2.7182817)
(my-assert
(macrolet ((foobar (a b)
`(+ ,a ,b)))
(foobar 2 4))
6)
(my-assert
(macrolet ((foobar (a b)
`(+ ,a ,b)))
(foobar 2 4 5 6))
program-error)
;;; From: Marco Antoniotti <marcoxa@parades.rm.cnr.it>
(my-assert
(progn
(defclass ccc () ())
(setf (find-class 'ccc1) (find-class 'ccc))
:ok)
:ok)
(my-assert
(progn
(defmethod zut ((c ccc1)) 123)
:ok)
:ok)
;;; From: Fred Gilham <gilham@snapdragon.csl.sri.com>
(my-assert
(progn
(compile-file "compile-bug2.lisp")
:ok)
:ok)
;;; From: lyle@cogni.iaf.cnrs-gif.fr (Lyle Borg-Graham)
(defun foo ()
(loop for x from 1.0 to 10.0
maximize x into max single-float))
(my-assert
(compile 'foo)
foo)
;;; From: Timothy Miller <tsm@cs.brown.edu>
#+(or cmu sbcl)
(my-assert
(> 2 single-float-positive-infinity)
NIL)
;;; From: "Fernando D. Mato Mira" <matomira@iname.com>
(defun prolog-length (p)
(let ((x (length (car p))))
(reduce #'(lambda (v1 v2)
(declare (ignore v1))
(setq x (+ x (length v2))))
p)))
(my-assert
(compile 'prolog-length)
prolog-length)
(my-assert
(prolog-length (list (list 1 2)
(list 3)))
3)
(my-assert
(progn
(compile-file "compile-bug3.lisp")
:ok)
:ok)
(my-assert
(progn
(compile-file "compile-bug4.lisp")
:ok)
:ok)
(my-assert
(progn
(compile-file "compile-bug4nt.lisp")
:ok)
:ok)
(my-assert
(prolog-length (list (list 1 2)
(list 3)))
3)
;;; From: Sam Steingold <sds@gnu.org>
#+UNIX
(my-assert
(let ((z (make-concatenated-stream
(make-string-input-stream "abc")
(open "/etc/hosts"))))
(read-line z)
(concatenated-stream-streams z)
:ok)
:ok)
;;; From: Hannu Koivisto <azure@iki.fi>
(my-assert
(case t)
nil)
;;; From: Raymond Toy <toy@rtp.ericsson.se>
(my-assert
(progn
(with-open-file (file "/tmp/foobar"
:direction :output
:if-exists :supersede)
(princ #\F file))
(with-open-file (file "/tmp/foobar"
:direction :input)
(let ((c (peek-char nil file nil 'eof t)))
(list c (read file)
(peek-char nil file nil 'eof t)))))
(#\F F EOF))
;;; From Barry Margolin:
#+cmu
(my-assert
(> (length
(pcl:generic-function-lambda-list
(ensure-generic-function 'change-class)))
2)
T
"change-class (instance t) (new-class symbol) &rest initargs")
;;; From the clisp CHANGES file:

32
src/ansi-tests/compile-bug1.lisp Normal file
View file

@ -0,0 +1,32 @@
(in-package :cl-user)
;; from Douglas Thomas Crosher <dtc@seagull.cons.org>
;;; Compiling this file caused a type error in
;;; maybe-convert-to-assignment due to a continuation-dest being
;;; null. One of the refs to the inlined definition of nthcdr had been
;;; marked for deletion, but this was seen. The path is ir1-optimize,
;;; flush-dead-code; delete-ref; then maybe-convert-to-assignment.
;;;
;;; After patching maybe-convert-to-assignment to abort in this case,
;;; the code compiles but compiles to a type error. Seems to be a
;;; problem propagating the argument type to the inlined nthcdr
;;; function?
;;;
(declaim (optimize (space 0) (debug 2)
(c::compilation-speed 0) (speed 0)
(c::brevity 0) (safety 0)))
(proclaim '(inline wrappers (setf wrappers)))
(defun wrappers (structure)
(declare (type list structure))
(elt structure 2))
(defun (setf wrappers) (new-value structure)
(declare (type list structure))
(setf (elt structure 2) new-value))
(defun tst (x)
(let ((wrappers (prog1 (wrappers x) (setf (wrappers x) nil)))
(fns (nthcdr 0 x)))
(car (nthcdr 0 x))))

33
src/ansi-tests/compile-bug2.lisp Normal file
View file

@ -0,0 +1,33 @@
(in-package :cl-user)
;;; From: Fred Gilham <gilham@snapdragon.csl.sri.com>
(let* ((original-read-table *readtable*)
(snepslog-read-table (copy-readtable nil))
(*readtable* snepslog-read-table))
(set-macro-character
#\,
#'(lambda (s c) (declare (ignore s c)) (quote \,)))
(set-macro-character
#\~
#'(lambda (s c) (declare (ignore s c)) (quote \~)))
(set-macro-character
#\.
#'(lambda (s c) (declare (ignore s c)) (quote \.)))
(set-macro-character
#\:
#'(lambda (s c) (declare (ignore s c)) (quote \:)))
(set-macro-character
#\{
#'(lambda (s c) (declare (ignore s c)) (quote \{)))
(set-macro-character
#\}
#'(lambda (s c) (declare (ignore s c)) (quote \})))
(defun snepslogreadon ()
"Sets the readtable to the snepslog read table"
(setq *readtable* snepslog-read-table))
(defun snepslogreadoff ()
"Sets the readtable to the original readtable
(a copy of the initial readtable)"
(setq *readtable* original-read-table)))

11
src/ansi-tests/compile-bug3.lisp Normal file
View file

@ -0,0 +1,11 @@
(in-package :cl-user)
;;; From: "Fernando D. Mato Mira" <matomira@iname.com>
(defun prolog-length (p)
(let ((x (length (car p))))
(reduce #'(lambda (v1 v2)
(declare (ignore v1))
(setq x (+ x (length v2))))
p)))

36
src/ansi-tests/compile-bug4.lisp Normal file
View file

@ -0,0 +1,36 @@
(in-package "CL-USER")
(defun equal-terms (termx termy)
(labels
((alpha-equal-bound-term-lists (listx listy)
(or (and (null listx) (null listy))
(and listx listy
(let ((bindings-x (bindings-of-bound-term (car listx)))
(bindings-y (bindings-of-bound-term (car listy))))
(if (and (null bindings-x) (null bindings-y))
(alpha-equal-terms (term-of-bound-term (car listx))
(term-of-bound-term (car listy)))
(and (= (length bindings-x) (length bindings-y))
(prog2
(enter-binding-pairs (bindings-of-bound-term (car listx))
(bindings-of-bound-term (car listy)))
(alpha-equal-terms (term-of-bound-term (car listx))
(alpha-equal-terms (term-of-bound-term (car listx))
(term-of-bound-term (car listy)))
(exit-binding-pairs (bindings-of-bound-term (car listx))
(bindings-of-bound-term (car listy)))))))
(alpha-equal-bound-term-lists (cdr listx) (cdr listy)))))
(alpha-equal-terms (termx termy)
(if (and (variable-p termx)
(variable-p termy))
(equal-bindings (id-of-variable-term termx)
(id-of-variable-term termy))
(and (equal-operators-p (operator-of-term termx) (operator-of-term termy))
(alpha-equal-bound-term-lists (bound-terms-of-term termx)
(bound-terms-of-term termy))))))
(or (eq termx termy)
(and termx termy
(with-variable-invocation (alpha-equal-terms termx termy)))))))

34
src/ansi-tests/compile-bug4nt.lisp Normal file
View file

@ -0,0 +1,34 @@
(in-package "USER")
(defun equal-terms (termx termy)
(labels
((alpha-equal-bound-term-lists (listx listy)
(or (and (null listx) (null listy))
(and listx listy
(let ((bindings-x (bindings-of-bound-term (car listx)))
(bindings-y (bindings-of-bound-term (car listy))))
(if (and (null bindings-x) (null bindings-y))
(alpha-equal-terms (term-of-bound-term (car listx))
(term-of-bound-term (car listy)))
(and (= (length bindings-x) (length bindings-y))
(prog2
(enter-binding-pairs (bindings-of-bound-term (car listx))
(bindings-of-bound-term (car listy)))
(alpha-equal-terms (term-of-bound-term (car listx))
(term-of-bound-term (car listy)))
(exit-binding-pairs (bindings-of-bound-term (car listx))
(bindings-of-bound-term (car listy)))))))
(alpha-equal-bound-term-lists (cdr listx) (cdr listy)))))
(alpha-equal-terms (termx termy)
(if (and (variable-p termx)
(variable-p termy))
(equal-bindings (id-of-variable-term termx)
(id-of-variable-term termy))
(and (equal-operators-p (operator-of-term termx) (operator-of-term termy))
(alpha-equal-bound-term-lists (bound-terms-of-term termx)
(bound-terms-of-term termy))))))
(or (eq termx termy)
(and termx termy
(with-variable-invocation (alpha-equal-terms termx termy))))))

20
src/ansi-tests/compile-bug5.lisp Normal file
View file

@ -0,0 +1,20 @@
(in-package :cl-user)
(defun tickle-bug ()
(labels ((fun1 ()
(fun2))
(fun2 ()
(when nil
(tagbody
tag
(fun2)
(go tag)))
(when nil
(tagbody
tag
(fun1)
(go tag)))))
(fun1)
nil))

9
src/ansi-tests/compile-bug6.lisp Normal file
View file

@ -0,0 +1,9 @@
(in-package :cl-user)
(defclass super1 () ())
(defclass sub1 (super1)())
(defun fooey ()
(make-instance 'sub1))

554
src/ansi-tests/conditions.lisp Normal file
View file

@ -0,0 +1,554 @@
;;; based on v1.6 -*- mode: lisp -*-
;;;; Test suite for the Common Lisp condition system
;;;; Written by David Gadbois <gadbois@cs.utexas.edu> 30.11.1993
(in-package :cl-user)
;;;
;;; Helpers
;;;
#+(or clisp allegro cmu sbcl)
(my-assert
#+CLISP
(defun my-cpl (class)
(clos::class-precedence-list (clos:find-class class))
)
#+ALLEGRO
(defun my-cpl (class)
(clos:finalize-inheritance (find-class class))
(clos:class-precedence-list (find-class class))
)
#+cmu
(defun my-cpl (class)
(pcl:class-precedence-list (find-class class))
)
#+sbcl
(defun my-cpl (class)
(sb-pcl:class-precedence-list (find-class class))
)
MY-CPL)
(my-assert
(defun check-superclasses (class expected)
(let ((expected (list* class 't
#+CLISP 'clos:standard-object
#+ALLEGRO 'standard-object
#+(or cmu sbcl) 'instance
'condition expected))
(super (mapcar #' #+CLISP clos:class-name
#+ALLEGRO class-name
#+cmu pcl:class-name
#+sbcl sb-pcl:class-name
(my-cpl class))))
(and (null (set-difference super expected))
(null (set-difference expected super)))))
CHECK-SUPERCLASSES)
;;;
;;; IGNORE-ERRORS
;;;
;;; If this does not work, none of the tests that check for getting an error
;;; will.
;;; IGNORE-ERRORS should work.
(my-assert
(multiple-value-bind (value condition)
(ignore-errors (error "Foo"))
(list value (type-of condition)))
(nil simple-error))
;;; IGNORE-ERRORS should not interfere with values in non-error situations.
(my-assert
(multiple-value-list
(ignore-errors (values 23 42)))
(23 42))
;;;
;;; Predefined condition types.
;;;
(my-assert
(check-superclasses 'warning '()) T)
(my-assert
(check-superclasses 'style-warning '(warning))
T)
(my-assert
(check-superclasses 'serious-condition '())
T)
(my-assert
(check-superclasses 'error '(serious-condition))
T)
(my-assert
(check-superclasses 'cell-error '(error serious-condition))
T)
(my-assert
(check-superclasses 'parse-error '(error serious-condition))
T)
(my-assert
(check-superclasses 'storage-condition '(serious-condition))
T)
(my-assert
(check-superclasses 'simple-error '(simple-condition error serious-condition))
T)
(my-assert
(check-superclasses 'simple-condition '())
T)
(my-assert
(check-superclasses 'simple-warning '(simple-condition warning))
T)
(my-assert
(check-superclasses 'file-error '(error serious-condition))
T)
(my-assert
(check-superclasses 'control-error '(error serious-condition))
T)
(my-assert
(check-superclasses 'program-error '(error serious-condition))
T)
(my-assert
(check-superclasses 'undefined-function '(cell-error error serious-condition))
T)
(my-assert
(check-superclasses 'arithmetic-error '(error serious-condition))
T)
(my-assert
(check-superclasses 'division-by-zero '(arithmetic-error error serious-condition))
T)
(my-assert
(check-superclasses 'floating-point-invalid-operation '(arithmetic-error error serious-condition))
T)
(my-assert
(check-superclasses 'floating-point-inexact '(arithmetic-error error serious-condition))
T)
(my-assert
(check-superclasses 'floating-point-overflow '(arithmetic-error error serious-condition))
T)
(my-assert
(check-superclasses 'floating-point-underflow '(arithmetic-error error serious-condition))
T)
(my-assert
(check-superclasses 'unbound-slot '(cell-error error serious-condition))
T)
(my-assert
(check-superclasses 'package-error '(error serious-condition))
T)
(my-assert
(check-superclasses 'print-not-readable '(error serious-condition))
T)
(my-assert
(check-superclasses 'reader-error '(parse-error stream-error error serious-condition))
T)
(my-assert
(check-superclasses 'stream-error '(error serious-condition))
T)
(my-assert
(check-superclasses 'end-of-file '(stream-error error serious-condition))
T)
(my-assert
(check-superclasses 'unbound-variable '(cell-error error serious-condition))
T)
(my-assert
(check-superclasses 'type-error '(error serious-condition))
T)
(my-assert
(check-superclasses 'simple-type-error
'(simple-condition
type-error error serious-condition))
T
"Condition Type SIMPLE-TYPE-ERROR
Class Precedence List:
simple-type-error, simple-condition, type-error, error, serious-condition, condition, t
")
;;;
;;; Defining conditions.
;;;
(my-assert
(progn (define-condition test () ()) t)
T)
(my-assert
(check-superclasses 'test '())
T)
(my-assert
(progn (define-condition test2 (test) ()) t)
T)
(my-assert
(check-superclasses 'test2 '(test))
T)
(my-assert
(progn (define-condition test3 (test2 simple-condition) ()) t)
T)
(my-assert
(check-superclasses 'test3 '(test2 test simple-condition))
T)
;;;
;;; Making conditions
;;;
(my-assert
(progn (make-condition 'test) t)
T)
(my-assert
(ignore-errors (progn (make-condition 'integer) t))
NIL)
;;;
;;; :REPORT option to DEFINE-CONDITION
;;;
(my-assert
(progn (define-condition test4 (test3)
()
(:report (lambda (condition stream)
(format stream "Yow! -- ~S" (type-of condition)))))
t)
T)
(my-assert
(with-output-to-string (s) (princ (make-condition 'test4) s))
"Yow! -- TEST4")
(my-assert
(progn (define-condition test5 (test4) ()) t)
T)
(my-assert
(with-output-to-string (s) (princ (make-condition 'test5) s))
"Yow! -- TEST5")
(my-assert
(with-output-to-string (s)
(princ (make-condition 'test3
:format-control "And How! -- ~S"
:format-arguments '(23)) s))
"And How! -- 23"
"From simple-condition:
The type simple-condition represents conditions that are signaled by
signal whenever a format-control is supplied as the function's first
argument. The format control and format arguments are initialized with
the initialization arguments named :format-control and
:format-arguments to make-condition, and are accessed by the functions
simple-condition-format-control and
simple-condition-format-arguments. If format arguments are not
supplied to make-condition, nil is used as a default. "
)
;;;
;;; Condition slots.
;;;
(my-assert
(progn (define-condition test6 (test4)
((foo :initarg :foo :initform 23 :accessor test6-foo))
(:report (lambda (condition stream)
(format stream "~S -- ~S"
(type-of condition)
(test6-foo condition)))))
t)
T)
(my-assert
(test6-foo (make-condition 'test6))
23)
(my-assert
(test6-foo (make-condition 'test6 :foo 42))
42)
(my-assert
(setf (test6-foo (make-condition 'test6 :foo 42)) 17)
17)
(my-assert
(with-output-to-string (s) (princ (make-condition 'test6 :foo 42) s))
"TEST6 -- 42")
;;;
;;; HANDLER-BIND
;;;
;;; You do not have to bind handlers.
(my-assert
(ignore-errors
(handler-bind
()
(error "Foo")))
nil)
;;; Handlers should not interfere with values in non-error situations.
(my-assert
(multiple-value-list
(block foo
(handler-bind
((error #'(lambda (c)
(declare (ignore c))
(return-from foo 23))))
(values 42 17))))
(42 17))
;;; Handlers should work.
(my-assert
(multiple-value-list
(block foo
(handler-bind
((error #'(lambda (c)
(declare (ignore c))
(return-from foo (values 23 17)))))
(error "Foo"))))
(23 17))
;;; Only the appropriate handlers should be called.
(my-assert
(ignore-errors
(block foo
(handler-bind
((type-error #'(lambda (c)
(declare (ignore c))
(return-from foo 23))))
(error "Foo"))))
nil)
;;; Handlers can be specified type expressions.
(my-assert
(block foo
(handler-bind
(((or type-error error)
#'(lambda (c)
(declare (ignore c))
(return-from foo 23))))
(error "Foo")))
23
"typespecifier can be non-trivial.")
;;; Handlers should be undone.
(my-assert
(ignore-errors
(block foo
(let ((first-time t))
(handler-bind
((error
#'(lambda (c)
(declare (ignore c))
(if first-time
(progn
(setq first-time nil)
(error "Bar"))
(return-from foo 23)))))
(error "Foo")))))
nil)
;;; Handlers should be undone.
(my-assert
(block foo
(let ((first-time t))
(handler-bind
((error
#'(lambda (c)
(declare (ignore c))
(return-from foo 23))))
(handler-bind
((error
#'(lambda (c)
(declare (ignore c))
(if first-time
(progn
(setq first-time nil)
(error "Bar"))
(return-from foo 42)))))
(error "Foo")))))
23)
;;; Handlers in the same cluster should be accessible.
(my-assert
(ignore-errors
(block foo
(handler-bind
((error
#'(lambda (c) (declare (ignore c)) nil))
(error
#'(lambda (c)
(declare (ignore c))
(return-from foo 23))))
(error "Foo"))))
23
"If a handler declines (ie. just return) the next available is used, so
the first one just returns nil, and the second, returning 23 is called")
;;; Multiple handlers should work.
(my-assert
(block foo
(handler-bind
((type-error
#'(lambda (c)
(declare (ignore c))
(return-from foo 42)))
(error
#'(lambda (c)
(declare (ignore c))
(return-from foo 23))))
(error "Foo")))
23)
;;; Handlers should be undone.
(my-assert
(block foo
(handler-bind
((error #'(lambda (c)
(declare (ignore c))
(return-from foo 23))))
(block bar
(handler-bind
((error #'(lambda (c)
(declare (ignore c))
(return-from foo 42))))
(return-from bar)))
(error "Foo")))
23)
;;;
;;; HANDLER-CASE
;;;
;;; HANDLER-CASE should handle errors.
(my-assert
(multiple-value-list
(handler-case
(error "Foo")
(error (c) (when (typep c 'error) (values 23 42)))))
(23 42))
;;; Except those it doesn't handle.
(my-assert
(ignore-errors
(handler-case
(error "Foo")
(type-error () 23)))
NIL)
;;; You don't have to specify handlers.
(my-assert
(ignore-errors
(handler-case
(error "Foo")))
NIL)
;;; HANDLER-CASE should not interfere with values in non-error situations.
(my-assert
(multiple-value-list
(handler-case
(values 42 17)
(error () 23)))
(42 17))
;;; :NO-ERROR should return values.
(my-assert
(multiple-value-list
(handler-case
(values 23 42)
(:no-error (a b)
(values b a))))
(42 23))
;;; Except when there is an error.
(my-assert
(handler-case
(error "Foo")
(error () 23)
(:no-error (&rest args) (declare (ignore args)) 42))
23)
;;; Or if it is not the last clause.
(my-assert
(handler-case
23
(:no-error (v) (1+ v))
(error () 42))
24
"The spec is not 100% clear here...
Macro HANDLER-CASE
Syntax:
handler-case expression [[{error-clause}* | no-error-clause]] => result*
clause::= error-clause | no-error-clause
So in the cause thing the no-error-clause can be everwhere,
in the real thing it looks like it can only be last.
Need to ask comp.lang.lisp...
")
;;; Multiple handlers should be OK.
(my-assert
(handler-case
(error "Foo")
(type-error () 23)
(error () 42))
42)
;;; Handlers should get undone.
(my-assert
(ignore-errors
(progn
(block foo
(handler-case
(return-from foo 23)
(error () 42)))
(error "Foo")))
NIL)
;;; Ditto.
(my-assert
(ignore-errors
(block foo
(let ((first-time t))
(handler-case
(error "Foo")
(error ()
(if first-time
(progn
(setf first-time nil)
(error "Bar"))
(return-from foo 23)))))))
NIL)

68
src/ansi-tests/eval20.lisp Normal file
View file

@ -0,0 +1,68 @@
;; based on v1.2 -*- mode: lisp -*-
(in-package :cl-user)
;; testen abschitt 20
;; eval
(my-assert
(eval (list 'cdr
'(car (list (cons 'a 'b) 'c))))
b)
(my-assert
(makunbound 'x)
x)
(my-assert
(eval 'x)
UNBOUND-VARIABLE)
(my-assert
(setf x 3)
3)
(my-assert
(eval 'x)
3)
;; constantp
(my-assert
(constantp 2)
T)
(my-assert
(constantp #\r)
T)
(my-assert
(constantp "max")
T)
(my-assert
(constantp '#(110))
T)
(my-assert
(constantp :max)
T)
(my-assert
(constantp T)
T)
(my-assert
(constantp NIL)
T)
(my-assert
(constantp 'PI)
#-CLISP T
#+CLISP NIL)
(my-assert
(constantp '(quote foo))
T)

1574
src/ansi-tests/excepsit.lisp Normal file
View file

File diff suppressed because it is too large Load diff

1295
src/ansi-tests/format.lisp Normal file
View file

File diff suppressed because it is too large Load diff

269
src/ansi-tests/hash.lisp Normal file
View file

@ -0,0 +1,269 @@
;;; based on v1.3 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(progn (in-package (quote sys)) t) t)
(my-assert
(make-hash-table :test (quote eq) :size 20)
#s(hash-table test eq size 20 %%size 64 rehash-size 2.0 %%rehash-size 2
rehash-threshold 13 %%rehash-threshold 13 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element)))
(my-assert
(make-hash-table :test (quote eql) :size 2)
#s(hash-table test eql size 2 %%size 4 rehash-size 2.0 %%rehash-size 2
rehash-threshold 13 %%rehash-threshold 2 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element)))
(my-assert
(make-hash-table :test (quote equal) :size 2)
#s(hash-table test equal size 2 %%size 4 rehash-size 2.0 %%rehash-size 2
rehash-threshold 13 %%rehash-threshold 2 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element)))
(my-assert
(progn (make-hash-table :test (function eq) :size 2) t) t)
(my-assert
(progn (make-hash-table :test (function eql) :size 2)t) t)
(my-assert
(make-hash-table :size nil)
error)
(my-assert
(make-hash-table :size -3)
error)
(my-assert
(make-hash-table :size 2.0)
error)
(my-assert
(make-hash-table :size 2 :rehash-size 1.5)
#s(hash-table test eql size 2 %%size 4 rehash-size 1.5 %%rehash-size 2
rehash-threshold 13 %%rehash-threshold 2 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element)))
(my-assert
(make-hash-table :size 2 :rehash-size -1.5)
error)
(my-assert
(make-hash-table :size 2 :rehash-size 0.5)
error)
(my-assert
(make-hash-table :size 2 :rehash-size 1.0)
#s(hash-table test eql size 2 %%size 4 rehash-size 1.0 %%rehash-size 4
rehash-threshold 13 %%rehash-threshold 2 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element)))
(my-assert
(make-hash-table :size 2 :rehash-size 5)
#s(hash-table test eql size 2 %%size 4 rehash-size 5 %%rehash-size 2
rehash-threshold 13 %%rehash-threshold 2 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element)))
(my-assert
(make-hash-table :size 4 :rehash-size 5.0)
#s(hash-table test eql size 4 %%size 8 rehash-size 5.0 %%rehash-size 8
rehash-threshold 13 %%rehash-threshold 3 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element)))
(my-assert
(make-hash-table :size 2 :rehash-size nil)
error)
(my-assert
(make-hash-table :size 2 :rehash-threshold nil)
error)
(my-assert
(make-hash-table :%%size 3)
#s(hash-table test eql size 16 %%size 3 rehash-size 2.0 %%rehash-size 2
rehash-threshold 13 %%rehash-threshold 13 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element)))
(my-assert
(setq tab (make-hash-table))
#s(hash-table test eql size 16 %%size 32 rehash-size 2.0 %%rehash-size 2
rehash-threshold 13 %%rehash-threshold 13 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element)))
(my-assert
(setf-gethash (quote hallo) tab (quote wiegwhts))
wiegwhts)
(my-assert
(setf-gethash (quote uhu) tab (quote kauz))
kauz)
(my-assert
(gethash (quote uhu) tab)
kauz)
(my-assert
(gethash uhu tab)
error)
(my-assert
(make-hash-table)
#s(hash-table test eql size 16 %%size 32 rehash-size 2.0 %%rehash-size 2
rehash-threshold 13 %%rehash-threshold 13 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element)))
(my-assert
(setq tab nil)
nil)
(my-assert
(setf-gethash (quote uhu) tab (quote kaus))
error)
(my-assert
(gethash (quote uhu) tab)
error)
(my-assert
(gethash (quote otto) tab)
error)
(my-assert
(setq tab (make-hash-table))
#s(hash-table test eql size 16 %%size 32 rehash-size 2.0 %%rehash-size 2
rehash-threshold 13 %%rehash-threshold 13 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element)))
(my-assert
(setf-gethash (quote uhu) tab (quote kaus))
kaus)
(my-assert
(gethash (quote uhu) tab)
kaus)
(my-assert
(gethash (quote otto) tab)
nil)
(my-assert
(setf-gethash (quote uhu) tab (quote kauz))
kauz)
(my-assert
(setf-gethash tab)
error)
(my-assert
(remhash (quote uhu) tab)
t)
(my-assert
tab
#s(hash-table test eql size 16 %%size 32 rehash-size 2.0 %%rehash-size 2
rehash-threshold 13 %%rehash-threshold 13 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element)))
(my-assert
(clrhash tab9)
error)
(my-assert
(clrhash tab)
#s(hash-table test eql size 16 %%size 32 rehash-size 2.0 %%rehash-size 2
rehash-threshold 13 %%rehash-threshold 13 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element)))
(my-assert
(hash-table-count tab)
0)
(my-assert
(setf-gethash (quote klak) tab (quote klase))
klase)
(my-assert
(setf-gethash (quote kunze) tab (quote riese))
riese)
(my-assert
(hash-table-p tab)
t)
(my-assert
(hash-table-count tab)
2)
(my-assert
(remhash (quote kunze) tab)
t)
(my-assert
(setf-gethash (quote wald) tab (quote khjgsfgjhdf))
khjgsfgjhdf)
(my-assert
(gethash)
error)
(my-assert
(remhash)
error)
(my-assert
(clrhash tab)
#s(hash-table test eql size 16 %%size 32 rehash-size 2.0 %%rehash-size 2
rehash-threshold 13 %%rehash-threshold 13 %%count 0 %%hash-vektor
#(%%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element %%empty-element %%empty-element
%%empty-element %%empty-element %%empty-element)))

63
src/ansi-tests/hashlong.lisp Normal file
View file

@ -0,0 +1,63 @@
;;; based on v1.2 -*- mode: lisp -*-
(in-package :cl-user)
#+clisp
(setf (symbol-function 'setf-gethash)
(symbol-function 'sys::puthash))
#+(or akcl ecls)
(setf (symbol-function 'setf-gethash)
(symbol-function 'sys:hash-set)) t
#+allegro
(setf (symbol-function 'setf-gethash)
(symbol-function 'excl::%puthash)) t
#+cmu
(setf (symbol-function 'setf-gethash)
(symbol-function 'cl::%puthash)) t
#+sbcl
(setf (symbol-function 'setf-gethash)
(symbol-function 'sb-impl::%puthash)) t
(my-assert
(defun symbole ()
(let ((b 0.)
(hash-table (make-hash-table :size 20.
:rehash-threshold
#+xcl 15.
#-xcl 0.75))
(liste (make-list 50.))
(liste2 (make-list 50.)))
(rplacd (last liste) liste)
(rplacd (last liste2) liste2)
(do-symbols (x (find-package #+xcl 'lisptest
#-xcl "LISP"))
;; (print x) (finish-output)
(cond ((car liste)
(let ((hval (gethash (car liste) hash-table))
(lval (car liste2)))
(unless (eq hval lval)
(print "mist, hash-tabelle kaputt")
(print (car liste))
(print hash-table)
(print (hash-table-count hash-table))
(print "hval:") (print hval)
(print "lval:") (print lval)
(return-from symbole 'error))
(remhash (car liste) hash-table)
#+xcl (when (< (room) 30000.) (system::%garbage-collection))
(setf-gethash x hash-table (setq b (+ 1. b)))
(rplaca liste x)
(rplaca liste2 b)
(setq liste (cdr liste))
(setq liste2 (cdr liste2))))
(t (setf-gethash x hash-table (setq b (+ 1. b)))
(rplaca liste x)
(rplaca liste2 b)
(setq liste (cdr liste))
(setq liste2 (cdr liste2)))))))
symbole)
(my-assert
(symbole) nil)

967
src/ansi-tests/iofkts.lisp Normal file
View file

@ -0,0 +1,967 @@
;;; based on v1.3 -*- mode: lisp -*-
(in-package :cl-user)
;; ****************************************************************************
;; * test der i/o-funktionen *
;; ****************************************************************************
#+xcl
(my-assert
(progn (in-package (quote sys)) t)
t)
;; --- let test ---------------------------------------------------------------
;; ewiger compiler-fehler
;;
(my-assert
(progn (setq bs (make-broadcast-stream)) t)
t)
#+xcl
(my-assert
*cur-broadcast-stream*
nil)
(my-assert
(print 123. bs)
123.)
#+xcl
(my-assert
*cur-broadcast-stream*
nil)
;; -------------------------------------------------------------------------------
;; unread test mit structure-stream
;;
(my-assert
(setq str1 "test 123456") "test 123456")
(my-assert
(progn (setq s1 (make-two-way-stream (make-string-input-stream str1)
*standard-output*)) t)
t)
(my-assert
(read s1) test)
(my-assert
(read-char s1) #\1)
(my-assert
(read-char s1) #\2)
(my-assert
(unread-char #\2 s1) nil)
(my-assert
(read-char s1) #\2)
(my-assert
(read-char s1) #\3)
(my-assert
(read-char s1) #\4)
(my-assert
(unread-char #\a s1) error
"I just read #\4 I cannot put #\a back")
(my-assert
(read-char s1) #\5 "The last unread should have failed, we're
out of sync")
(my-assert
(read-char s1) #\6 "still out of sync?")
(my-assert
(close s1) t)
(my-assert
str1 "test 123456")
;; -------------------------------------------------------------------------------
(my-assert
(multiple-value-list (parse-integer "abc"))
error)
(my-assert
(multiple-value-list (parse-integer " abc "))
error)
(my-assert
(multiple-value-list (parse-integer "123"))
(123 3))
(my-assert
(multiple-value-list (parse-integer " 123 "))
#-(or cmu sbcl)
(123 7)
#+(or cmu sbcl)
(123 5))
(my-assert
(multiple-value-list (parse-integer "123 t"))
error)
(my-assert
(multiple-value-list (parse-integer " 123 t "))
error)
(my-assert
(multiple-value-list (parse-integer " ( 12 ) 43 t "))
error)
(my-assert
(multiple-value-list (parse-integer " abc " :junk-allowed t))
(nil 2))
(my-assert
(multiple-value-list (parse-integer "123" :junk-allowed t))
(123 3))
(my-assert
(multiple-value-list (parse-integer " 123 " :junk-allowed t))
(123 #+xcl 7
#+(or clisp akcl allegro cmu sbcl ecls) 5
#-(or xcl clisp akcl allegro cmu sbcl ecls) unknown))
(my-assert
(multiple-value-list (parse-integer "123 t" :junk-allowed t))
(123 #+xcl 4
#+(or clisp akcl allegro cmu sbcl ecls) 3
#-(or xcl clisp akcl allegro cmu sbcl ecls) unknown))
(my-assert
(multiple-value-list (parse-integer " 123 t " :junk-allowed t))
(123 #+xcl 8
#+(or clisp akcl allegro cmu sbcl ecls) 5
#-(or xcl clisp akcl allegro cmu sbcl ecls) unknown))
(my-assert
(multiple-value-list (parse-integer " ( 12 ) 43 t " :junk-allowed
t))
(nil 1))
(my-assert
(setq a "q w e 1 2 r 4 d : :;;;")
"q w e 1 2 r 4 d : :;;;")
(my-assert
(setq b "1 2 3 4 5 6 7")
"1 2 3 4 5 6 7")
(my-assert
(setq c "1.3 4.223")
"1.3 4.223")
(my-assert
(setq d "q w e r t z")
"q w e r t z")
(my-assert
(multiple-value-list (parse-integer a))
error)
(my-assert
(multiple-value-list (parse-integer b))
error)
(my-assert
(multiple-value-list (parse-integer c))
error)
(my-assert
(multiple-value-list (parse-integer d))
error)
(my-assert
(multiple-value-list (parse-integer a :start 4 :end 6))
error)
(my-assert
(multiple-value-list (parse-integer b :start 2 :end 3))
(2 3))
(my-assert
(multiple-value-list (parse-integer c :start 1))
error)
(my-assert
(multiple-value-list (parse-integer d :start 6))
error)
(my-assert
(multiple-value-list (parse-integer a :end 4))
error)
(my-assert
(multiple-value-list (parse-integer b :end 3))
error)
(my-assert
(multiple-value-list (parse-integer c :end 3))
error)
(my-assert
(multiple-value-list (parse-integer d :end 1))
error)
(my-assert
(multiple-value-list (parse-integer a :radix 1))
error)
(my-assert
(multiple-value-list (parse-integer b :radix 10))
error)
(my-assert
(multiple-value-list (parse-integer c :radix 20))
error)
(my-assert
(multiple-value-list (parse-integer d :radix 40))
error)
(my-assert
(multiple-value-list (parse-integer a :junk-allowed t))
(nil 0))
(my-assert
(multiple-value-list (parse-integer b :junk-allowed t))
(1 #+xcl 2
#+(or clisp akcl allegro cmu sbcl ecls) 1
#-(or xcl clisp akcl allegro cmu sbcl) unknown))
(my-assert
(multiple-value-list (parse-integer c :junk-allowed t))
(1 1))
(my-assert
(multiple-value-list (parse-integer d :junk-allowed t))
(nil 0))
(my-assert
(stream-element-type #+xcl stdin
#-xcl *terminal-io*)
character)
(my-assert
(progn (setq a (make-string-input-stream "aaa bbb")) t)
t)
(my-assert
(read a)
aaa)
#+xcl
(my-assert
(b-clear-input a)
nil)
(my-assert
(read a)
#+xcl error
#-xcl bbb)
(my-assert
(progn (setq a (make-string-output-stream))
(setq b (make-string-output-stream))
(setq c (make-broadcast-stream a b)) t)
t)
(my-assert
(print "xxx" c)
"xxx")
(my-assert
(clear-output c)
nil)
(my-assert
(finish-output c)
#+xcl t
#-xcl nil)
(my-assert
(get-output-stream-string a)
"
\"xxx\" ")
(my-assert
(get-output-stream-string b)
"
\"xxx\" ")
(my-assert
(print "yyy" c)
"yyy")
(my-assert
(clear-output c)
nil)
(my-assert
(finish-output c)
#+xcl t
#-xcl nil)
(my-assert
(print "zzz" a)
"zzz")
(my-assert
(clear-output a)
nil)
(my-assert
(finish-output a)
#+xcl t
#-xcl nil)
(my-assert
(get-output-stream-string a)
#+xcl ""
#-xcl "
\"yyy\"
\"zzz\" ")
(my-assert
(get-output-stream-string b)
"
\"yyy\" ")
(my-assert
(progn (setq a (make-string-input-stream "123")) t)
t)
(my-assert
(listen a)
t)
(my-assert
(read a)
123)
(my-assert
(listen a)
nil)
(my-assert
*print-case*
:upcase)
(my-assert
*print-gensym*
t)
(my-assert
*print-level*
nil)
(my-assert
*print-length*
nil)
(my-assert
*print-array*
t)
(my-assert
*print-escape*
t)
(my-assert
*print-pretty*
nil)
(my-assert
*print-circle*
nil)
(my-assert
*print-base*
10)
(my-assert
*print-radix*
nil)
(my-assert
(setq string1 "Das ist ein Test mit Print ")
"Das ist ein Test mit Print ")
(my-assert
(prin1-to-string string1)
"\"das ist ein test mit print \"")
(my-assert
(princ-to-string string1)
"Das ist ein Test mit Print ")
(my-assert
(progn (setq a (make-string-input-stream "123")) t)
t)
(my-assert
(read-char-no-hang a)
#\1)
(my-assert
(read a)
23)
(my-assert
(read-char-no-hang a)
error)
(my-assert
(read-char-no-hang a nil "EOF")
"EOF")
(my-assert
(progn (setq a (make-string-input-stream "1 2 ;32 abA"))
(setq b (make-string-input-stream " 1 2 3 A x y z
a b c")) t)
t)
(my-assert
(read-delimited-list #\A b)
(1 2 3))
(my-assert
(setq c (multiple-value-list (read-line b)))
(" x y z" nil))
(my-assert
(length c)
2)
(my-assert
(multiple-value-list (read-line b))
("a b c" t))
(my-assert
(multiple-value-list (read-line b))
error)
(my-assert
(multiple-value-list (read-line b nil "EOF"))
("EOF" t)
"read-line &optional input-stream eof-error-p eof-value recursive-p
=> line, missing-newline-p
")
(my-assert
(peek-char nil a)
#\1)
(my-assert
(read-char a)
#\1)
(my-assert
(peek-char t a)
#\2)
(my-assert
(read-char a)
#\2)
(my-assert
(peek-char t a)
#\;)
(my-assert
(read-char a)
#\;)
(my-assert
(peek-char #\A a)
#\A)
(my-assert
(read-char a)
#\A)
(my-assert
(peek-char nil a)
error)
(my-assert
(peek-char nil a nil "EOF")
"EOF")
(my-assert
(setq a (quote
((berlin (dresden frankfurt bonn muenchen)) (mueller (karl luise dieter
aldo)))))
((berlin (dresden frankfurt bonn muenchen)) (mueller (karl luise dieter
aldo))))
(my-assert
(progn (setq aa (make-string-input-stream "berlin d mueller :r")) t)
t)
(my-assert
(defun ask (&optional (res nil))
" (terpri)(terpri)(terpri)
(print '(*** Eingabe des Keywortes ***))
(print '(- mit :r reset))
(terpri)" (setq x (read aa)) " (print x)" (cond
((equal x (quote :r)) (cons "--- reset ---" res))
(t (cons (cadr (assoc x a)) (ask res)))))
ask)
(my-assert
(ask)
((dresden frankfurt bonn muenchen) nil (karl luise dieter aldo) "--- reset ---"))
(my-assert
(setq string1 "Das ist ein Teststring")
"Das ist ein Teststring")
(my-assert
(setq string2 "Auch das 1 2 3 ist ein Teststring")
"Auch das 1 2 3 ist ein Teststring")
(my-assert
(multiple-value-list (read-from-string string1))
(das 4))
(my-assert
(multiple-value-list (read-from-string string2))
(auch 5))
(my-assert
(multiple-value-list (read-from-string string1 t nil :start 2))
(s 4))
(my-assert
(multiple-value-list
(read-from-string string1 t nil :start 2 :preserve-whitespace t))
(s 3))
(my-assert
(multiple-value-list (read-from-string string2 t nil :start 5))
(das 9))
(my-assert
(multiple-value-list (read-from-string string2 t nil :start 5 :end
6))
(d 6))
(my-assert
(multiple-value-list (read-from-string string1 t nil :start 4 :end
3))
error)
(my-assert
(multiple-value-list (read-from-string string1 t nil :end 0))
error)
(my-assert
(multiple-value-list (read-from-string string1 t nil :start -2 :end
0))
error)
(my-assert
(multiple-value-list (read-from-string string1 t nil :end 2))
(da 2))
(my-assert
*read-suppress*
nil)
(my-assert
(standard-char-p (quote a))
error)
(my-assert
(standard-char-p (quote #\backspace))
#+xcl t
#-xcl nil)
(my-assert
(standard-char-p (quote #\tab))
#+xcl t
#-xcl nil)
(my-assert
(standard-char-p (quote #\newline))
t)
(my-assert
(standard-char-p (quote #\page))
#+xcl t
#-xcl nil)
(my-assert
(standard-char-p (quote #\return))
#+xcl t
#-xcl nil)
#-(or cmu sbcl sbcl)
(my-assert
(string-char-p (quote a))
error)
(my-assert
(characterp (quote
#\space))
t)
(my-assert
(characterp (quote
#\newline))
t)
(my-assert
(characterp (quote
#\backspace))
t)
(my-assert
(characterp (quote
#\a))
t)
(my-assert
(characterp (quote
#\8))
t)
(my-assert
(characterp (quote
#\-))
t)
(my-assert
(characterp (quote
#\n))
t)
(my-assert
(characterp (quote
#\())
t)
(my-assert
(stringp "das ist einer der Teststrings")
t)
(my-assert
(stringp (quote (das ist natuerlich falsch)))
nil)
(my-assert
(stringp "das ist die eine Haelfte" "und das die andere")
error)
(my-assert
(setq j 0)
0)
(my-assert
(with-input-from-string (s "animal crackers" :start 6) (read s))
crackers)
(my-assert
(with-input-from-string (s "animal crackers" :index j :start 6) (read s))
crackers)
(my-assert
j
15)
(my-assert
(with-input-from-string (s "animal crackers" :index j :start 7) (read s))
crackers)
(my-assert
j
15)
(my-assert
(with-input-from-string (s "animal crackers" :index j :start 2) (read s))
imal)
(my-assert
j
7)
(my-assert
(with-input-from-string (s "animal crackers" :index j :start 0 :end 6) (read s))
animal)
(my-assert
j
6)
(my-assert
(with-input-from-string (s "animal crackers"
:index j
:start 0 :end 12)
(read s))
animal)
(my-assert
j
7)
(my-assert
(with-input-from-string (s "animal crackers" :index j :start -1) (read s))
error)
(my-assert
j
7)
(my-assert
(with-input-from-string (s "animal crackers"
:index j
:start 6 :end 20)
(read s))
#+xcl
crackers
#+(or clisp akcl allegro sbcl cmu ecls)
error
#-(or xcl clisp akcl allegro sbcl cmu ecls)
unknown)
(my-assert
j
#+xcl
20
#+(or clisp akcl allegro sbcl cmu ecls)
7
#-(or xcl clisp akcl allegro sbcl cmu ecls)
unknown)
(my-assert
(setq a "Das ist wieder einmal einer der SUUPERTESTstrings.")
"Das ist wieder einmal einer der SUUPERTESTstrings.")
(my-assert
(progn (setq b (make-string-output-stream)) t)
t)
(my-assert
(write-string a b)
"Das ist wieder einmal einer der SUUPERTESTstrings.")
(my-assert
(write-string a b :start 10)
"Das ist wieder einmal einer der SUUPERTESTstrings.")
(my-assert
(write-string a b :start 80)
#+xcl "Das ist wieder einmal einer der SUUPERTESTstrings."
#-xcl error)
(my-assert
(write-string a b :end 5)
"Das ist wieder einmal einer der SUUPERTESTstrings.")
(my-assert
(write-string a b :end -2)
error)
(my-assert
(write-string a b :end 100)
#+(or sbcl cmu xcl)
"Das ist wieder einmal einer der SUUPERTESTstrings."
#-(or sbcl cmu xcl)
error)
(my-assert
(write-string a b :start 5 :end 20)
"Das ist wieder einmal einer der SUUPERTESTstrings.")
(my-assert
(write-string a b :start 10 :end 5)
#+xcl "Das ist wieder einmal einer der SUUPERTESTstrings."
#-xcl error)
(my-assert
(get-output-stream-string b)
#+(or sbcl cmu xcl)
"Das ist wieder einmal einer der SUUPERTESTstrings.eder einmal einer der SUUPERTESTstrings.Das iDas ist wieder einmal einer der SUUPERTESTstrings.st wieder einma"
#+(or clisp akcl ecls)
"Das ist wieder einmal einer der SUUPERTESTstrings.eder einmal einer der SUUPERTESTstrings.Das ist wieder einma"
#-(or xcl clisp akcl sbcl cmu ecls)
unknown)
(my-assert
(write-string a b)
"Das ist wieder einmal einer der SUUPERTESTstrings.")
(my-assert
(length (get-output-stream-string b))
50)
(my-assert
(write-line a b)
"Das ist wieder einmal einer der SUUPERTESTstrings.")
(my-assert
(length (get-output-stream-string b))
51)
(my-assert
(with-output-to-string (s) (print (quote xxx) s))
"
XXX ")
(my-assert
(let ((a (make-array 10
:element-type 'character
:fill-pointer 0)))
a)
"")
(my-assert
(let ((a (make-array 10
:element-type 'character
:fill-pointer 0)))
(with-output-to-string (s a) (princ 123 s)))
123)
(my-assert
(let ((a (make-array 10
:element-type 'character
:fill-pointer 0)))
(with-output-to-string (s a) (princ 123 s))
a)
"123")
(my-assert
(let ((a (make-array 10
:element-type 'character
:fill-pointer 0)))
(with-output-to-string (s a) (princ 123 s))
(with-output-to-string (s a) (princ 4567 s)))
4567)
(my-assert
(let ((a (make-array 10
:element-type 'character
:fill-pointer 0)))
(with-output-to-string (s a) (princ 123 s))
(with-output-to-string (s a) (princ 4567 s))
a)
"1234567")
(my-assert
(let ((a (make-array 10
:element-type 'character
:fill-pointer 0)))
(with-output-to-string (s a) (princ 123 s))
(with-output-to-string (s a) (princ 4567 s))
(with-output-to-string (s a)
(princ 890 s)))
890)
(my-assert
(let ((a (make-array 10
:element-type 'character
:fill-pointer 0)))
(with-output-to-string (s a) (princ 123 s))
(with-output-to-string (s a) (princ 4567 s))
(with-output-to-string (s a)
(princ 890 s))
a)
"1234567890")
(my-assert
(let ((a (make-array 10
:element-type 'character
:fill-pointer 0)))
(with-output-to-string (s a) (princ 123 s))
(with-output-to-string (s a) (princ 4567 s))
(with-output-to-string (s a)
(princ 890 s))
(with-output-to-string (s a)
(princ (quote a) s)))
error
"All 10 characters are up. This should fail")
(my-assert
(let ((a (make-array 10
:element-type 'character
:fill-pointer 0)))
(with-output-to-string (s a) (princ 123 s))
(with-output-to-string (s a) (princ 4567 s))
(with-output-to-string (s a)
(princ 890 s))
(ignore-errors
(with-output-to-string (s a)
(princ (quote a) s)))
a)
"1234567890")
(my-assert
(setq a
(make-array 10 :element-type 'character
:fill-pointer 0
:adjustable t))
"")
(my-assert
(with-output-to-string (s a) (princ 123 s))
123)
(my-assert
a
"123")
(my-assert
(with-output-to-string (s a) (princ 4567 s))
4567)
(my-assert
a
"1234567")
(my-assert
(with-output-to-string (s a) (princ 890 s))
890)
(my-assert
a
"1234567890")
(my-assert
(with-output-to-string (s a) (princ (quote abcde) s))
abcde)
(my-assert
a
"1234567890ABCDE")
(my-assert
(with-output-to-string (s a) (princ (quote fghi) s))
fghi)
(my-assert
a
"1234567890ABCDEFGHI")
(makunbound 'bs)
(makunbound 'a)
(makunbound 'b)
(makunbound 'c)
(makunbound 'd)
(makunbound 'aa)
(makunbound 'string1)
(makunbound 'string2)
(makunbound 'x)
(makunbound 'j)
(makunbound 's1)
(makunbound 'str1)

279
src/ansi-tests/lambda.lisp Normal file
View file

@ -0,0 +1,279 @@
;;; based on 1.1.1.1 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(makunbound 'b) b)
(my-assert
(makunbound 'e) e)
(my-assert
(setq z 2) 2)
(my-assert
((lambda (z) (declare (special z)) (list z (symbol-value 'z))) 3)
(3 3))
(my-assert
(makunbound 'z) z)
(my-assert
((lambda (a b) (+ a (* b 3))) 4 5)
19)
(my-assert
((lambda (a &optional (b 2)) (+ a (* b 3))) 4 5)
19)
(my-assert
((lambda (a &optional (b 2)) (+ a (* b 3))) 4)
10)
(my-assert
((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)))
(2 nil 3 nil nil))
(my-assert
((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6)
(6 t 3 nil nil))
(my-assert
((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3)
(6 t 3 t nil))
(my-assert
((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3
8)
(6 t 3 t (8)))
(my-assert
((lambda (&optional (a 2 b) (c 3 d) &rest x) (list a b c d x)) 6 3
8 9 10 11)
(6 t 3 t (8 9 10 11)))
(my-assert
((lambda (a b &key c d) (list a b c d)) 1 2)
(1 2 nil nil))
(my-assert
((lambda (a b &key c d) (list a b c d)) 1 2 :c 6)
(1 2 6 nil))
(my-assert
((lambda (a b &key c d) (list a b c d)) 1 2 :d 8)
(1 2 nil 8))
(my-assert
((lambda (a b &key c d) (list a b c d)) 1 2 :c 6 :d 8)
(1 2 6 8))
(my-assert
((lambda (a b &key c d) (list a b c d)) 1 2 :d 8 :c 6)
(1 2 6 8))
(my-assert
((lambda (a b &key c d) (list a b c d)) :a 1 :d 8 :c 6)
(:a 1 6 8))
(my-assert
((lambda (a b &key c d) (list a b c d)) :a :b :c :d)
(:a :b :d nil))
(my-assert
((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x))
1)
(1 3 nil 1 nil))
(my-assert
((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x))
1 2)
(1 2 nil 1 nil))
(my-assert
((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x))
:c 7)
(:c 7 nil :c nil))
(my-assert
((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x))
1 6 :c 7)
(1 6 7 1 (:c 7)))
(my-assert
((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x))
1 6 :d 8)
(1 6 nil 8 (:d 8)))
(my-assert
((lambda (a &optional (b 3) &rest x &key c (d a)) (list a b c d x))
1 6 :d 8 :c
9 :d 10)
(1 6 9 8 (:d 8 :c 9 :d 10)))
(my-assert
((lambda (x &aux (a 3) (b 4)) (+ x (* a b))) 2)
14)
(my-assert
((lambda (x y &optional a b &rest z &key c (d y) &aux (u 3) (v 4))
(+ x y a (* b (car z)) c (* d u) v))
3 4 5 2 7 :c 6 :d 8)
program-error)
(my-assert
((lambda (x y &optional a b &rest z &key c (d y) &aux (u 3) (v 4))
(+ x y a (* b (car z)) c (* d u) v))
3 4 5 2 7 :c 6)
program-error)
(my-assert
((lambda (x &aux c) (cons x c)) (quote a))
(a))
(my-assert
((lambda (x &rest y z) (list x y z)) 1 2 3)
error)
(my-assert
((lambda (5 a b) (list a b)) 1 2)
error)
(my-assert
((lambda ((length (quote (a b))) c) (list c)) 1)
error)
(my-assert
((lamda (x &key :y :z) (list x y z)) 1 :y 2 :z 3)
error)
(my-assert
((lambda (x y) (list x y z)) 1 2)
unbound-variable)
(my-assert
((lambda (x y) (list x y z)) 1 2 3)
error)
(my-assert
((lambda (&optional) (list a b c)) 1)
error)
(my-assert
((lambda (&optional (a)) (list a)) 1)
(1))
(my-assert
((lambda (&optional (a b)) (list a b)) 1)
unbound-variable)
(my-assert
((lambda (&optional (a 3 b)) (list a b)) 1)
(1 t))
(my-assert
((lambda (&optional (a 3)) (list a)) 1)
(1))
(my-assert
((lambda (&optional (a 3 b 4)) (list a b)) 1)
#+xcl (1 t)
#-xcl error)
(my-assert
((lambda (x) (list x y)) 1 2)
error)
(my-assert
((lambda (x) (list x)) 1 2)
error)
(my-assert
((lambda (#\a) (list a)) 1)
error)
(my-assert
((lambda (#*10) (list 1 2 3)))
error)
(my-assert
((lambda (x y) ((lambda (a b) (list a b)) (quote u) (quote v))) 5 6)
(u v))
(my-assert
((lambda (x y) (list x y)) 1)
error)
(my-assert
((lambda (x &rest y &optional (z 5)) (list x y z)) 1 3)
error)
(my-assert
((lambda (x &x) (list x)) 7)
error)
(my-assert
((lambda (x &aux) (list x)) 6)
(6))
(my-assert
((lambda (x &aux y) (list x y)) 6)
(6 nil))
(my-assert
((lambda (x &aux (y)) (list x y)) 6)
(6 nil))
(my-assert
((lambda (x &rest) (list x)) 2)
error)
(my-assert
((lambda (x &key) (list x)) 3)
(3))
(my-assert
((lambda (x &key y) (list x)) 3)
(3))
(my-assert
((lambda (x &key y) (list x)) 3 :y)
error)
(my-assert
((lambda (x &key y) (list x)) :\3)
(:\3))
(my-assert
((lambda nil (list 1 2 3)))
(1 2 3))
(my-assert
((lambda nil (list 1 2 3)) 4 5)
error)
(my-assert
((lambda (list 1 2 3)))
error)
(my-assert
((lambda (x)))
error)
(my-assert
((lambda (&aux &key &rest &optional)))
error)
(my-assert
((lambda (a b &key c d &allow-other-keys) (list a b c d e f)) 1 2 :c
6 :d 8 :e 5
:f 7)
error)
(my-assert
((lambda (x &allow-other-keys) (list x y)) 2 :y 3)
error)
(my-assert
((lambda))
error)

837
src/ansi-tests/lists151.lisp Normal file
View file

@ -0,0 +1,837 @@
;;; based on v1.1.1.1 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(makunbound 'a)
a)
(my-assert
(makunbound 'x)
x)
(my-assert
(car '(a b c d e f g))
a)
(my-assert
(cdr '(a b c d e f g))
(b c d e f g))
(my-assert
(caar '((a) b c d e f g))
a)
(my-assert
(cadr '(a b c d e f g))
b)
(my-assert
(cdar '((a b) c d e f g))
(b))
(my-assert
(cddr '(a b c d e f g))
(c d e f g))
(my-assert
(caaar '(((a)) b c d e f g))
a)
(my-assert
(caadr '(a (b) c d e f g))
b)
(my-assert
(cadar '((a b) c d e f g))
b)
(my-assert
(caddr '(a b c d e f g))
c)
(my-assert
(cdaar '(((a b)) c d e f g))
(b))
(my-assert
(cdadr '(a (b c) d e f g))
(c))
(my-assert
(cddar '((a b c) d e f g))
(c))
(my-assert
(cdddr '(a b c d e f g))
(d e f g))
(my-assert
(caaaar '((((a))) b c d e f g))
a)
(my-assert
(caaadr '(a ((b)) c d e f g))
b)
(my-assert
(caadar '((a (b)) c d e f g))
b)
(my-assert
(caaddr '(a b (c) d e f g))
c)
(my-assert
(cadaar '(((a b)) c d e f g))
b)
(my-assert
(cadadr '(a (b c) d e f g))
c)
(my-assert
(caddar '((a b c) d e f g))
c)
(my-assert
(cadddr '(a b c d e f g))
d)
(my-assert
(cdaaar '((((a b))) c d e f g))
(b))
(my-assert
(cdaadr '(a ((b c)) d e f g))
(c))
(my-assert
(cdadar '((a (b c)) d e f g))
(c))
(my-assert
(cdaddr '(a b (c d) e f g))
(d))
(my-assert
(cddaar '(((a b c)) d e f g))
(c))
(my-assert
(cddadr '(a (b c d) e f g))
(d))
(my-assert
(cdddar '((a b c d) e f g))
(d))
(my-assert
(cddddr '(a b c d e f g))
(e f g))
(my-assert
(car '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
((((1 2 3) 4) 5) (6 7)))
(my-assert
(cdr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
((((u v w) x) y) ((q w e) r) (a b c) e f g))
(my-assert
(caar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
(((1 2 3) 4) 5))
(my-assert
(cadr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
(((u v w) x) y))
(my-assert
(cdar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
((6 7)))
(my-assert
(cddr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
(((q w e) r) (a b c) e f g))
(my-assert
(caaar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
((1 2 3) 4))
(my-assert
(caadr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
((u v w) x))
(my-assert
(cadar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
(6 7))
(my-assert
(caddr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
((q w e) r))
(my-assert
(cdaar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
(5))
(my-assert
(cdadr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
(y))
(my-assert
(cddar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
nil)
(my-assert
(cdddr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b c)
e f g))
((a b c) e f g))
(my-assert
(caaaar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
(1 2 3))
(my-assert
(caaadr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
(u v w))
(my-assert
(caadar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
6)
(my-assert
(caaddr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
(q w e))
(my-assert
(cadaar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
5)
(my-assert
(cadadr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
y)
(my-assert
(caddar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
nil)
(my-assert
(cadddr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
(a b c))
(my-assert
(cdaaar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
(4))
(my-assert
(cdaadr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
(x))
(my-assert
(cdadar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
(7))
(my-assert
(cdaddr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
(r))
(my-assert
(cddaar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
nil)
(my-assert
(cddadr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
nil)
(my-assert
(cdddar '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
nil)
(my-assert
(cddddr '(((((1 2 3) 4) 5) (6 7)) (((u v w) x) y) ((q w e) r) (a b
c) e f g))
(e f g))
(my-assert
(car 'nil)
nil)
(my-assert
(cdr 'nil)
nil)
(my-assert
(caar 'nil)
nil)
(my-assert
(cadr 'nil)
nil)
(my-assert
(cdar 'nil)
nil)
(my-assert
(cddr 'nil)
nil)
(my-assert
(caaar 'nil)
nil)
(my-assert
(caadr 'nil)
nil)
(my-assert
(cadar 'nil)
nil)
(my-assert
(caddr 'nil)
nil)
(my-assert
(cdaar 'nil)
nil)
(my-assert
(cdadr 'nil)
nil)
(my-assert
(cddar 'nil)
nil)
(my-assert
(cdddr 'nil)
nil)
(my-assert
(caaaar 'nil)
nil)
(my-assert
(caaadr 'nil)
nil)
(my-assert
(caadar 'nil)
nil)
(my-assert
(caaddr 'nil)
nil)
(my-assert
(cadaar 'nil)
nil)
(my-assert
(cadadr 'nil)
nil)
(my-assert
(caddar 'nil)
nil)
(my-assert
(cadddr 'nil)
nil)
(my-assert
(cdaaar 'nil)
nil)
(my-assert
(cdaadr 'nil)
nil)
(my-assert
(cdadar 'nil)
nil)
(my-assert
(cdaddr 'nil)
nil)
(my-assert
(cddaar 'nil)
nil)
(my-assert
(cddadr 'nil)
nil)
(my-assert
(cdddar 'nil)
nil)
(my-assert
(cddddr 'nil)
nil)
(my-assert
(car '(a b c d e f g))
a)
(my-assert
(cdr '(a b c d e f g))
(b c d e f g))
(my-assert
(caar '(a b c d e f g))
type-error)
(my-assert
(cadr '(a b c d e f g))
b)
(my-assert
(cdar '(a b c d e f g))
type-error)
(my-assert
(cddr '(a b c d e f g))
(c d e f g))
(my-assert
(caaar '(a b c d e f g))
type-error)
(my-assert
(caadr '(a b c d e f g))
type-error)
(my-assert
(cadar '(a b c d e f g))
type-error)
(my-assert
(caddr '(a b c d e f g))
c)
(my-assert
(cdaar '(a b c d e f g))
type-error)
(my-assert
(cdadr '(a b c d e f g))
type-error)
(my-assert
(cddar '(a b c d e f g))
type-error)
(my-assert
(cdddr '(a b c d e f g))
(d e f g))
(my-assert
(caaaar '(a b c d e f g))
type-error)
(my-assert
(caaadr '(a b c d e f g))
type-error)
(my-assert
(caadar '(a b c d e f g))
type-error)
(my-assert
(caaddr '(a b c d e f g))
type-error)
(my-assert
(cadaar '(a b c d e f g))
type-error)
(my-assert
(cadadr '(a b c d e f g))
type-error)
(my-assert
(caddar '(a b c d e f g))
type-error)
(my-assert
(cadddr '(a b c d e f g))
d)
(my-assert
(cdaaar '(a b c d e f g))
type-error)
(my-assert
(cdaadr '(a b c d e f g))
type-error)
(my-assert
(cdadar '(a b c d e f g))
type-error)
(my-assert
(cdaddr '(a b c d e f g))
type-error)
(my-assert
(cddaar '(a b c d e f g))
type-error)
(my-assert
(cddadr '(a b c d e f g))
type-error)
(my-assert
(cdddar '(a b c d e f g))
type-error)
(my-assert
(cddddr '(a b c d e f g))
(e f g))
(my-assert
(car '(a))
a)
(my-assert
(cdr '(a))
nil)
(my-assert
(caar '(a))
type-error)
(my-assert
(cadr '(a))
nil)
(my-assert
(cdar '(a))
type-error)
(my-assert
(cddr '(a))
nil)
(my-assert
(caaar '(a))
type-error)
(my-assert
(caadr '(a))
nil)
(my-assert
(cadar '(a))
type-error)
(my-assert
(caddr '(a))
nil)
(my-assert
(cdaar '(a))
type-error)
(my-assert
(cdadr '(a))
nil)
(my-assert
(cddar '(a))
type-error)
(my-assert
(cdddr '(a))
nil)
(my-assert
(caaaar '(a))
type-error)
(my-assert
(caaadr '(a))
nil)
(my-assert
(caadar '(a))
type-error)
(my-assert
(caaddr '(a))
nil)
(my-assert
(cadaar '(a))
type-error)
(my-assert
(cadadr '(a))
nil)
(my-assert
(caddar '(a))
type-error)
(my-assert
(cadddr '(a))
nil)
(my-assert
(cdaaar '(a))
type-error)
(my-assert
(cdaadr '(a))
nil)
(my-assert
(cdadar '(a))
type-error)
(my-assert
(cdaddr '(a))
nil)
(my-assert
(cddaar '(a))
type-error)
(my-assert
(cddadr '(a))
nil)
(my-assert
(cdddar '(a))
type-error)
(my-assert
(cddddr '(a))
nil)
(my-assert
(cons 1 2)
(1 . 2))
(my-assert
(cons 'a 'b)
(a . b))
(my-assert
(cons 'a 'b 'c)
program-error)
(my-assert
(cons 'a)
program-error)
(my-assert
(cons)
program-error)
(my-assert
(cons 'a 'nil)
(a))
(my-assert
(cons 'nil 'a)
(nil . a))
(my-assert
(cons 'a (cons 'b (cons 'c 'nil)))
(a b c))
(my-assert
(cons 'a '(b c d))
(a b c d))
(my-assert
(tree-equal 1 1)
t)
(my-assert
(tree-equal 'word 'word)
t)
(my-assert
(tree-equal 'word1 'word2)
nil)
(my-assert
(tree-equal '(a b) '(a b))
t)
(my-assert
(tree-equal '(a (b c)) '((a b) c))
nil)
(my-assert
(tree-equal 5 (+ 2 3))
t)
(my-assert
(tree-equal '(a (b quote nil)) '(a (b)))
nil)
(my-assert
(tree-equal '(a (b . 1.0)) '(a (b #c(1.0 0.0))))
nil)
(my-assert
(tree-equal 1 1 :test #'eq)
t)
(my-assert
(tree-equal 'word 'word :test #'eq)
t)
(my-assert
(tree-equal 'word1 'word2 :test #'eq)
nil)
(my-assert
(tree-equal '(a b) '(a b) :test #'eq)
t)
(my-assert
(tree-equal '(a (b c)) '((a b) c) :test #'eq)
nil)
(my-assert
(tree-equal 5 (+ 2 3) :test #'eq)
t)
(my-assert
(tree-equal '(a (b)) '(a (b)) :test #'eq)
t)
(my-assert
(tree-equal '(a (b . 1.0)) '(a (b #c(1.0 0.0))) :test #'eq)
nil)
(my-assert
(tree-equal 1 1 :test #'eql)
t)
(my-assert
(tree-equal 'word 'word :test #'eql)
t)
(my-assert
(tree-equal 'word1 'word2 :test #'eql)
nil)
(my-assert
(tree-equal '(a b) '(a b) :test #'eql)
t)
(my-assert
(tree-equal '(a (b c)) '((a b) c) :test #'eql)
nil)
(my-assert
(tree-equal 5 (+ 2 3) :test #'eql)
t)
(my-assert
(tree-equal '(a (b)) '(a (b)) :test #'eql)
t)
(my-assert
(tree-equal '(a (b . 1.0)) '(a (b #c(1.0 0.0))) :test #'eql)
nil)
(my-assert
(tree-equal 1 1 :test #'equal)
t)
(my-assert
(tree-equal 'word 'word :test #'equal)
t)
(my-assert
(tree-equal 'word1 'word2 :test #'equal)
nil)
(my-assert
(tree-equal '(a b) '(a b) :test #'equal)
t)
(my-assert
(tree-equal '(a (b c)) '((a b) c) :test #'equal)
nil)
(my-assert
(tree-equal 5 (+ 2 3) :test #'equal)
t)
(my-assert
(tree-equal '(a (b)) '(a (b)) :test #'equal)
t)
(my-assert
(tree-equal '(a (b . 1.0)) '(a (b #c(1.0 0.0))) :test #'equal)
nil)
(my-assert
(tree-equal 1 1 :test-not #'eq)
nil)
(my-assert
(tree-equal 'word 'word :test-not #'eq)
nil)
(my-assert
(tree-equal 'word1 'word2 :test-not #'eq)
t)
(my-assert
(tree-equal '(a b) '(a b) :test-not #'eq)
nil)
(my-assert
(tree-equal '(a (b c)) '((a b) c) :test-not #'eq)
nil)
(my-assert
(tree-equal 5 (+ 2 3) :test-not #'eq)
nil)
(my-assert
(tree-equal '(a (b)) '(a (b)) :test-not #'eq)
nil)
(my-assert
(tree-equal '(a (b . 1.0)) '(a (b #c(1.0 0.0))) :test-not #'eq)
nil)

1056
src/ansi-tests/lists152.lisp Normal file
View file

File diff suppressed because it is too large Load diff

5
src/ansi-tests/lists153.lisp Normal file
View file

@ -0,0 +1,5 @@
;;; based on v1.1.1.1 -*- mode: lisp -*-
(in-package :cl-user)
;; RPLACA
;; RPLACD

288
src/ansi-tests/lists154.lisp Normal file
View file

@ -0,0 +1,288 @@
;;; based on v1.1.1.1 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(subst 'a 'b
'(u b
(b)
c))
(u a
(a)
c))
(my-assert
(subst 'a 'b
'(u b
(b)
c)
:test-not
#'(lambda (x y)
(if (atom y)
(eql x y)
t)))
(a b
(b . a)
a . a))
(my-assert
(subst 'a 'b
'(u b
(b)
c)
:test
#'(lambda (x y)
(not (eql x y))))
a)
(my-assert
(subst 'a 'b
'(u b
(b)
c)
:test-not
#'(lambda (x y)
(not (eql x y))))
(u a
(a)
c))
(my-assert
(subst 'a 'b
'(u b
(b)
c)
:test-not
#'(lambda (x y)
(not (eql x y)))
:key
#'(lambda (u)
(if (listp u)
(car u))))
(u . a))
(my-assert
(subst-if 'nummmer 'numberp
'((a (7 (v 6)))))
((a (nummmer (v nummmer)))))
(my-assert
(subst-if-not 'nummmer 'numberp
'((a (7 (v 6)))))
nummmer)
(my-assert
(subst-if-not 'nummmer
#'(lambda (x)
(and (listp x)
(numberp x)))
'((a (7 (v 6)))))
nummmer)
(my-assert
(subst-if-not 'nummmer
#'(lambda (x)
(or (listp x)
(numberp x)))
'((a (7 (v 6)))))
((nummmer (7 (nummmer 6)))))
(my-assert
(nsubst 'a 'b
'(u b
(b)
c)
:test-not
#'(lambda (x y)
(if (atom y)
(eql x y)
t)))
(a b
(b . a)
a . a))
(my-assert
(nsubst 'a 'b
'(u b
(b)
c)
:test-not
#'(lambda (x y)
(not (eql x y))))
(u a
(a)
c))
(my-assert
(nsubst 'a 'b
'(u b
(b)
c)
:test
#'(lambda (x y)
(not (eql x y))))
a)
(my-assert
(nsubst-if 'oo 'numberp
'(a b c
(3 (4)
0)))
(a b c
(oo (oo)
oo)))
(my-assert
(nsubst-if-not 'oo 'numberp
'(a b c
(3 (4)
0)))
oo)
(my-assert
(nsubst-if-not 'oo
#'(lambda (x)
(or (atom x)
(numberp x)))
'(a b c
(3 (4)
0)))
oo)
(my-assert
(nsubst-if-not 'oo
#'(lambda (x)
(and (atom x)
(numberp x)))
'(a b c
(3 (4)
0)))
oo)
(my-assert
(nsubst-if-not 'oo
#'(lambda (x)
(or (list x)
(numberp x)))
'(a b c
(3 (4)
0)))
(a b c
(3 (4)
0)))
(my-assert
(nsubst-if-not 'oo
#'(lambda (x)
(or (list x)
(symbolp x)))
'(a b c
(3 (4)
0)))
(a b c
(3 (4)
0)))
(my-assert
(sublis '((a . a1)
(b . b1))
'(a b))
(a1 b1))
(my-assert
(sublis '((a . a1)
(b . b1))
'(a b
(b . c)))
(a1 b1
(b1 . c)))
(my-assert
(sublis '((a . a1)
(b . b1)
(nil . nil1))
'(a b
(b . c)))
(a1 b1
(b1 . c) .
nil1))
(my-assert
(sublis '((a . a1)
(b . b1)
(nil . nil1))
'(a b
(b c)))
(a1 b1
(b1 c . nil1) .
nil1))
(my-assert
(sublis '((a . a1)
(b . b1)
(nil . nil1))
'(a b
(b c))
:test-not 'eql)
a1)
(my-assert
(sublis '((a . a1)
(b . b1)
(nil . nil1))
'(a b
(b c))
:test-not
#'(lambda (x y)
(if (atom y)
(eql x y))))
a1)
(my-assert
(sublis '(((a) .
uu)
(a . ii))
'(i (a)
a))
(i (ii)
ii))
(my-assert
(sublis '(((a) . uu) (a . ii))
'(i (a) a)
:key #'(lambda (x) (if (listp x) (car x))))
(i ii . ii)) ; key wird angewandt auf: x ein blatt des baumes
(my-assert
(sublis '(((a) . uu) (a . ii))
'(i (a) a)
:test #'(lambda (x y) (if (listp y) (eql x (car y)))))
#+(or xcl akcl lucid allegro ecls) (i ii . ii) ; x aus der aliste, y ein blatt des baumes
#+(or clisp cmu sbcl) (i (uu) uu) ; x ein blatt, y aus der aliste
#-(or xcl clisp akcl cmu sbcl lucid allegro ecls) unknown)
(my-assert
(nsublis '(((a) . uu) (a . ii))
'(i (a) a)
:key #'(lambda (x) (if (listp x) (car x))))
(i ii . ii)) ; key wird angewandt auf: x ein blatt des baumes
(my-assert
(nsublis '(((a) . uu) (a . ii))
'(i (a) a)
:test #'(lambda (x y) (if (listp x) (equal x y))))
(i uu . uu))
(my-assert
(nsublis '(((a) . uu) (a . ii))
'(i (a) a)
:test #'(lambda (x y) (if (listp y) (equal x y))))
(i uu . uu))
(my-assert
(nsublis '(((a) . uu) (a . ii))
'(i (a) a)
:test #'(lambda (x y) (if (listp y) (eql x (car y)))))
#+(or xcl akcl allegro ecls) (i ii . ii) ; x aus der aliste, y ein blatt des baumes
#+(or clisp cmu sbcl lucid) (i (uu) uu) ; x ein blatt, y aus der aliste
#-(or xcl clisp akcl cmu sbcl lucid allegro ecls) unknown)

203
src/ansi-tests/lists155.lisp Normal file
View file

@ -0,0 +1,203 @@
;;; based on v1.2 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(member 'a
'((a)
(b)
(a)
(c)))
nil)
(my-assert
(member 'a
'((a)
(b)
(a)
(c))
:key 'car)
((a)
(b)
(a)
(c)))
(my-assert
(member-if 'numberp
'((a)
(b)
(3)
(c))
:key 'car)
((3)
(c)))
(my-assert
(member-if-not 'numberp
'((8)
(a)
(b)
(3)
(c))
:key 'car)
((a)
(b)
(3)
(c)))
(my-assert
(tailp '(a b)
'(u a b))
nil)
(my-assert
(tailp (cddr (setq xx
'(u i a b)))
xx)
t)
(my-assert
(tailp (cddr (setq xx
'(u i a b)))
xx)
t)
(my-assert
(adjoin 'a
'(a b c))
(a b c))
(my-assert
(adjoin 'a
'((a)
b c)
:test 'equal)
(a (a)
b c))
(my-assert
(adjoin 'a
'((a)
b c)
:test 'equal)
(a (a)
b c))
(my-assert
(union '(a b c d)
'(a d i v))
#+xcl (v i a b c d)
#+(or clisp akcl ecls) (b c a d i v)
#+(or allegro cmu sbcl) (c b a d i v)
#-(or xcl clisp akcl allegro cmu sbcl ecls) unknown)
(my-assert
(nunion '(a b c d)
'(u i b a))
#+xcl (a b c d u i)
#+(or clisp akcl ecls) (c d u i b a)
#+(or allegro cmu sbcl) (d c u i b a)
#-(or xcl clisp akcl allegro cmu sbcl ecls) unknown)
(my-assert
(nintersection '(a b c d)
'(c d e f g))
#+(or xcl clisp gcl ecls) (c d)
#+(or allegro cmu sbcl) (d c)
#-(or xcl clisp gcl allegro cmu sbcl ecls) unknown)
(my-assert
(nintersection '(a b c d)
'(c d e f g)
:test-not 'eql)
#+(or xcl clisp gcl ecls) (a b c d)
#+(or allegro cmu sbcl) (d c b a)
#-(or xcl clisp gcl allegro cmu sbcl ecls) unknown)
(my-assert
(set-difference '(a b c d e)
'(d b e))
#+(or xcl allegro gcl cmu sbcl ecls) (c a)
#+(or clisp (and akcl (not gcl))) (a c)
#-(or xcl clisp akcl allegro cmu sbcl ecls) unknown)
(my-assert
(set-difference
'(auto anton berta berlin)
'(a)
:test
#'(lambda (x y)
(eql (elt (symbol-name x)
1)
(elt (symbol-name y)
1))))
#+(or xcl allegro)
(berlin berta anton auto)
#-(or xcl allegro)
type-error)
(my-assert
(set-difference '(anton berta auto berlin)
'(amerilla)
:test
#'(lambda (x y)
(eql (elt (symbol-name x)
0)
(elt (symbol-name y)
0))))
#+(or xcl gcl allegro cmu sbcl) (berlin berta)
#+(or clisp (and akcl (not gcl)) ecls) (berta berlin)
#-(or xcl clisp akcl allegro cmu sbcl ecls) unknown)
(my-assert
(nset-difference '(a b c d)
'(i j c))
#+(or xcl clisp gcl ecls) (a b d)
#+(or allegro cmu sbcl) (d b a)
#-(or xcl clisp gcl allegro cmu sbcl ecls) unknown)
(my-assert
(set-exclusive-or '(a b c d)
'(c a i l))
#+(or xcl gcl) (d b l i)
#+(or clisp (and akcl (not gcl)) ecls) (b d i l)
#+(or allegro cmu sbcl) (l i d b)
#-(or xcl clisp akcl allegro cmu sbcl ecls) unknown)
(my-assert
(set-exclusive-or '(anton anna emil)
'(berta auto august)
:test
#'(lambda (x y)
(eql (elt (symbol-name x)
0)
(elt (symbol-name y)
0))))
#+(or xcl clisp gcl ecls) (emil berta)
#+(or allegro cmu sbcl) (berta emil)
#-(or xcl clisp gcl allegro cmu sbcl ecls) unknown)
(my-assert
(nset-exclusive-or '(a b c)
'(i a d c))
(b i d))
(my-assert
(subsetp '(a b)
'(b u i a c d))
t)
(my-assert
(subsetp '(a b)
'(b u i c d))
nil)
(my-assert
(subsetp '(a b)
'(b a u i c d))
t)
(my-assert
(subsetp '(a b)
'(a u i c d))
nil)

183
src/ansi-tests/lists156.lisp Normal file
View file

@ -0,0 +1,183 @@
;;; based on v1.2 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(ACONS 'A 'B NIL)
((A . B)))
(my-assert
(ACONS 'A 'B
'((C . D)))
((A . B)
(C . D)))
(my-assert
(PAIRLIS '(A B C)
'(1 2))
#+XCL
((B . 2)
(A . 1))
#-XCL
ERROR)
(my-assert
(PAIRLIS '(A B C)
'(1 2 3))
#+(or XCL CLISP ALLEGRO cmu sbcl ecls)
((C . 3)
(B . 2)
(A . 1))
#+AKCL ((A . 1) (B . 2) (C . 3))
#-(or XCL CLISP AKCL ALLEGRO cmu sbcl ecls) UNKNOWN)
(my-assert
(ASSOC 'A
'((B C)
(A U)
(A I)))
(A U))
(my-assert
(ASSOC 'A
'((B C)
((A)
U)
(A I)))
(A I))
(my-assert
(ASSOC 'A
'((B C)
((A)
U)
(A I))
:KEY
#'(LAMBDA (X)
(IF (LISTP X)
(CAR X))))
((A)
U))
(my-assert
(ASSOC 'A
'((B C)
A
((A)
U)
(A I))
:KEY
#'(LAMBDA (X)
(IF (LISTP X)
(CAR X))))
#-(or GCL ALLEGRO cmu sbcl)
((A) U)
#+(or GCL ALLEGRO cmu sbcl)
TYPE-ERROR)
(my-assert
(ASSOC 'A
'((B C)
A
((A)
U)
(A I))
:KEY
#'(LAMBDA (X)
(IF (ATOM X)
X)))
#-(or GCL ALLEGRO cmu sbcl) (A I)
#+(or GCL ALLEGRO cmu sbcl)
TYPE-ERROR)
(my-assert
(ASSOC 'A
'((B C)
A
((A)
U)
(A I))
:TEST
#'(LAMBDA (X Y)
(IF (LISTP Y)
(EQL (CAR Y)
X))))
#-(or GCL ALLEGRO cmu sbcl) ((A) U)
#+(or GCL ALLEGRO cmu sbcl)
TYPE-ERROR)
(my-assert
(ASSOC 'A
'((B C)
A
((A)
U)
(A I))
:TEST
#'(LAMBDA (X Y)
(IF (ATOM Y)
(EQL Y X))))
#-(or GCL ALLEGRO cmu sbcl) (A I)
#+(or GCL ALLEGRO cmu sbcl) ERROR)
(my-assert
(ASSOC 'A
'((B C)
A
((A)
U)
(A I))
:TEST-NOT
#'(LAMBDA (X Y)
(IF (ATOM Y)
(EQL Y X))))
#-ALLEGRO (B C)
#+ALLEGRO ERROR)
(my-assert
(ASSOC-IF 'NUMBERP
'((A . 3)
(3 . A)))
(3 . A))
(my-assert
(ASSOC-IF 'SYMBOLP
'((A . 3)
(3 . A)))
(A . 3))
(my-assert
(ASSOC-IF-NOT 'SYMBOLP
'((A . 3)
(3 . A)))
(3 . A))
(my-assert
(ASSOC-IF-NOT 'NUMBERP
'((A . 3)
(3 . A)))
(A . 3))
(my-assert
(RASSOC 'A
'((1 . B)
(2 . A)))
(2 . A))
(my-assert
(RASSOC-IF 'SYMBOLP
'((1 . B)
(2 . A)))
(1 . B))
(my-assert
(RASSOC-IF 'SYMBOLP
'((1 . 3)
(2 . A)))
(2 . A))
(my-assert
(RASSOC-IF-NOT 'SYMBOLP
'((1 . 3)
(2 . A)))
(1 . 3))

937
src/ansi-tests/loop.lisp Normal file
View file

@ -0,0 +1,937 @@
;;; based on v1.5 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(loop for x from 1 to 9
for y = nil then x
collect (list x y)
)
((1 NIL) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9)))
(my-assert
(loop for x from 1 to 9
and y = nil then x
collect (list x y)
)
((1 NIL) (2 1) (3 2) (4 3) (5 4) (6 5) (7 6) (8 7) (9 8)))
(my-assert
(with-output-to-string (*standard-output*)
(loop as i from 1 to 5
do (print i)
) )
"
1
2
3
4
5 ")
(my-assert
(with-output-to-string (*standard-output*)
(loop for i from 10 downto 1 by 3
do (print i)
) )
"
10
7
4
1 ")
(my-assert
(with-output-to-string (*standard-output*)
(loop as i below 5
do (print i)
) )
"
0
1
2
3
4 ")
(my-assert
(with-output-to-string (*standard-output*)
(loop for item in '(1 2 3 4 5)
do (print item)
) )
"
1
2
3
4
5 ")
(my-assert
(with-output-to-string (*standard-output*)
(loop for item in '(1 2 3 4 5) by #'cddr
do (print item)
) )
"
1
3
5 ")
(my-assert
(loop for (item . x) (t . fixnum) in '((A . 1) (B . 2) (C . 3))
unless (eq item 'B) sum x
)
4)
(my-assert
(loop for sublist on '(a b c d)
collect sublist
)
((A B C D) (B C D) (C D) (D)))
(my-assert
(with-output-to-string (*standard-output*)
(loop for (item) on '(1 2 3)
do (print item)
) )
"
1
2
3 ")
(my-assert
(with-output-to-string (*standard-output*)
(loop for item in '(1 2 3)
do (print item)
) )
"
1
2
3 ")
(my-assert
(loop for i below 5
for j = 10 then i
collect j
)
(10 1 2 3 4))
(my-assert
(loop for i below 5
for j = i
collect j
)
(0 1 2 3 4))
(my-assert
(loop for item = 1 then (+ item 10)
repeat 5
collect item
)
(1 11 21 31 41))
(my-assert
(loop for char across (the simple-string "Hello")
collect char
)
(#\H #\e #\l #\l #\o))
(my-assert
(with-output-to-string (*standard-output*)
(loop repeat 3
do (write-line "What I say three times is true")
) )
"What I say three times is true
What I say three times is true
What I say three times is true
")
(my-assert
(with-output-to-string (*standard-output*)
(loop repeat -15
do (write-line "What you see is what you expect")
) )
"")
#|;; FOR clauses should come before WHILE clauses
(let ((stack '(a b c d e f)))
(loop while stack
for item = (length stack) then (pop stack)
collect item
) )
(6 A B C D E F)
|#
(my-assert
(loop for i fixnum from 3
when (oddp i) collect i
while (< i 5)
)
(3 5))
(my-assert
(loop for i from 0 to 10
always (< i 11)
)
T)
(my-assert
(loop for i from 0 to 10
never (> i 11)
)
T)
(my-assert
(loop for i from 0
thereis (when (> i 10) i)
)
11)
(my-assert
(with-output-to-string (*standard-output*)
(loop for i from 0 to 10
always (< i 9)
finally (print "You won't see this")
) )
"")
(my-assert
(with-output-to-string (*standard-output*)
(loop never t
finally (print "You won't see this")
) )
"")
(my-assert
(with-output-to-string (*standard-output*)
(loop thereis "Here is my value"
finally (print "You won't see this")
) )
"")
(my-assert
(loop thereis "Here is my value"
finally (print "You won't see this")
)
"Here is my value")
(my-assert
(with-output-to-string (*standard-output*)
(loop for i from 1 to 10
thereis (> i 11)
finally (print i)
) )
"
11 ")
(my-assert
(let (everest chocorua sahara)
(defstruct mountain height difficulty (why "because it is there"))
(setq everest (make-mountain :height '(2.86e-13 parsecs)))
(setq chocorua (make-mountain :height '(1059180001 microns)))
(defstruct desert area (humidity 0))
(setq sahara (make-desert :area '(212480000 square furlongs)))
(loop for x in (list everest sahara chocorua)
thereis (and (mountain-p x) (mountain-height x))
) )
(2.86e-13 parsecs))
(my-assert
(with-output-to-string (*standard-output*)
(loop for (month date-list) in '((january (24 28)) (february (17 29 12)))
do (loop for date in date-list
do (case date
(29 (when (eq month 'february) (loop-finish)))
)
do (format t "~:(~A~) ~A~%" month date)
) ) )
"January 24
January 28
February 17
")
(my-assert
(loop for i in '(1 2 3 stop-here 4 5 6)
when (symbolp i) do (loop-finish)
count i
)
3)
(my-assert
(loop for i in '(1 2 3 stop-here 4 5 6)
until (symbolp i)
count i
)
3)
(my-assert
(loop for name in '(fred sue alice joe june)
for kids in '((bob ken) () () (kris sunshine) ())
collect name
append kids
)
(FRED BOB KEN SUE ALICE JOE KRIS SUNSHINE JUNE))
(my-assert
(multiple-value-list
(loop for name in '(fred sue alice joe june)
as age in '(22 26 19 20 10)
append (list name age) into name-and-age-list
count name into name-count
sum age into total-age
finally
(return (values (round total-age name-count) name-and-age-list))
) )
(19 (FRED 22 SUE 26 ALICE 19 JOE 20 JUNE 10)))
(my-assert
(loop for i in '(bird 3 4 turtle (1 . 4) horse cat)
when (symbolp i) collect i
)
(BIRD TURTLE HORSE CAT))
(my-assert
(loop for i from 1 to 10
if (oddp i) collect i
)
(1 3 5 7 9))
(my-assert
(with-output-to-string (*standard-output*)
(loop for i in '(a b c d) by #'cddr
collect i into my-list
finally (print my-list)
) )
"
(A C) ")
(my-assert
(loop for x in '((a) (b) ((c)))
append x
)
(A B (C)))
(my-assert
(loop for i upfrom 0
as x in '(a b (c))
nconc (if (evenp i) (list x) '())
)
(A (C)))
(my-assert
(loop for i in '(a b nil c nil d e)
count i
)
5)
(my-assert
(loop for i fixnum in '(1 2 3 4 5)
sum i
)
15)
(my-assert
(let ((series '(1.2 4.3 5.7)))
(loop for v in series
sum (* 2.0 v)
) )
22.4)
(my-assert
(loop for i in '(2 1 5 3 4)
maximize i
)
5)
(my-assert
(loop for i in '(2 1 5 3 4)
minimize i
)
1)
(my-assert
(let ((series '(1.2 4.3 5.7)))
(loop for v in series
maximize (round v) fixnum
) )
6)
(my-assert
(let ((series '(1.2 4.3 5.7)))
(loop for v in series
minimize (round v) into result fixnum
finally (return result)
) )
1)
(my-assert
(loop with a = 1
with b = (+ a 2)
with c = (+ b 3)
with d = (+ c 4)
return (list a b c d)
)
(1 3 6 10))
(my-assert
(loop with a = 1
and b = 2
and c = 3
and d = 4
return (list a b c d)
)
(1 2 3 4))
(my-assert
(let ((a 5) (b 10) (c 1729))
(loop with a = 1
and b = (+ a 2)
and c = (+ b 3)
and d = (+ c 4)
return (list a b c d)
) )
(1 7 13 1733))
(my-assert
(loop with (a b c) (float integer float)
return (format nil "~A ~A ~A" a b c)
)
"0.0 0 0.0")
(my-assert
(loop with (a b c) float
return (format nil "~A ~A ~A" a b c)
)
"0.0 0.0 0.0")
(my-assert
(let ((numbers-list '(3 2 4 6 1 7 8)) (results nil))
(cons
(with-output-to-string (*standard-output*)
(loop for i in numbers-list
when (oddp i)
do (print i)
and collect i into odd-numbers
and do (terpri)
else
collect i into even-numbers
finally (setq results (list odd-numbers even-numbers))
) )
results
) )
("
3
1
7
"
(3 1 7) (2 4 6 8)))
(my-assert
(loop for i in '(1 2 3 4 5 6)
when (and (> i 3) i)
collect it
)
(4 5 6))
(my-assert
(loop for i in '(1 2 3 4 5 6)
when (and (> i 3) i)
return it
)
4)
(my-assert
(loop for i in '(1 2 3 4 5 6)
thereis (and (> i 3) i)
)
4)
(my-assert
(with-output-to-string (*standard-output*)
(loop for x from 0 to 3
do (print x)
if (zerop (mod x 2))
do (write-string " a")
and
if (zerop (floor x 2))
do (write-string " b")
and
do (write-string " c")
) )
"
0 a b c
1
2 a
3 ")
(my-assert
(with-output-to-string (*standard-output*)
(loop for x from 0 to 3
do (print x)
if (zerop (mod x 2))
do (write-string " a")
and
if (zerop (floor x 2))
do (write-string " b")
end
and
do (write-string " c")
) )
"
0 a b c
1
2 a c
3 ")
(my-assert
(with-output-to-string (*standard-output*)
(loop for i from 1 to 5
do (print i)
) )
"
1
2
3
4
5 ")
(my-assert
(with-output-to-string (*standard-output*)
(loop for i from 1 to 4
do (print i)
(print (* i i))
) )
"
1
1
2
4
3
9
4
16 ")
(my-assert
(loop for item in '(1 2 3 a 4 5)
when (not (numberp item))
return (format nil "non-numeric value: ~S" item)
)
"non-numeric value: A")
(my-assert
(loop for item in '(1 2 3 a 4 5)
when (not (numberp item))
do (return (format nil "non-numeric value: ~S" item))
)
"non-numeric value: A")
(my-assert
(loop for numlist in '((1 2 4.0) (5 6 8.3) (8 9 10.4))
for a integer = (first numlist)
for b integer = (second numlist)
for c float = (third numlist)
collect (list c b a)
)
((4.0 2 1) (8.3 6 5) (10.4 9 8)))
;; According to the BNF syntax, "and" must not be followed by "for". But
;; ANSI CL section 6.1.1.5.1 contains ambiguous wording, and this example
;; appears in CLtL2 p. 743, we keep it.
(my-assert
(loop for numlist in '((1 2 4.0) (5 6 8.3) (8 9 10.4))
for a integer = (first numlist)
and for b integer = (second numlist)
and for c float = (third numlist)
collect (list c b a)
)
#-(OR CMU SBCL) ((4.0 2 1) (8.3 6 5) (10.4 9 8))
#+(OR CMU SBCL) ERROR)
(my-assert
(loop for numlist in '((1 2 4.0) (5 6 8.3) (8 9 10.4))
for a integer = (first numlist)
and b integer = (second numlist)
and c float = (third numlist)
collect (list c b a)
)
((4.0 2 1) (8.3 6 5) (10.4 9 8)))
(my-assert
(loop for (a b c) (integer integer float) in '((1 2 4.0) (5 6 8.3) (8 9 10.4))
collect (list c b a)
)
((4.0 2 1) (8.3 6 5) (10.4 9 8)))
(my-assert
(loop for (a b c) float in '((1.0 2.0 4.0) (5.0 6.0 8.3) (8.0 9.0 10.4))
collect (list c b a)
)
((4.0 2.0 1.0) (8.3 6.0 5.0) (10.4 9.0 8.0)))
(my-assert
(loop with (a b) float = '(1.0 2.0)
and (c d) integer = '(3 4)
and (e f)
return (list a b c d e f)
)
(1.0 2.0 3 4 NIL NIL))
(my-assert
(loop for (a nil b) = '(1 2 3)
do (return (list a b))
)
(1 3))
(my-assert
(loop for (x . y) = '(1 . 2)
do (return y)
)
2)
(my-assert
(loop for ((a . b) (c . d)) of-type ((float . float) (integer . integer))
in '(((1.2 . 2.4) (3 . 4)) ((3.4 . 4.6) (5 . 6)))
collect (list a b c d)
)
((1.2 2.4 3 4) (3.4 4.6 5 6)))
(my-assert
(loop for buffer in '("\"Hello\"" "\"unterminated" "nothing")
collect
(loop initially (unless (char= (char buffer 0) #\") (loop-finish))
for i fixnum from 1 below (length buffer)
when (char= (char buffer i) #\")
return i
) )
(6 NIL NIL))
(my-assert
(let (result)
(list
(with-output-to-string (*standard-output*)
(setq result
(loop for i from 1 to 10
when (> i 5)
collect i
finally (print i)
) ) )
result
) )
("
11 " (6 7 8 9 10)))
(my-assert
(multiple-value-list
(loop for i from 1 to 10
when (> i 5)
collect i into number-list
and count i into number-count
finally (return (values number-count number-list))
) )
(5 (6 7 8 9 10)))
(my-assert
(let (result)
(list
(with-output-to-string (*standard-output*)
(setq result
(loop named max
for i from 1 to 10
do (print i)
do (return-from max 'done)
) ) )
result
) )
("
1 " DONE))
;;; The following tests are not mandatory according to dpANS or ANSI CL,
;;; but that's how users expect the LOOP macro to work, so we check them.
(my-assert
(loop for i = 0
for j to 2
collect j
)
(0 1 2))
(my-assert
(loop for i in '(1 2)
for j = i
for k = j
collect (list i j k)
)
((1 1 1) (2 2 2)))
(my-assert
(loop for idx upfrom 0 below 5
for char = (aref "Error" idx)
collect char
)
(#\E #\r #\r #\o #\r))
(my-assert
(let ((hash-table (make-hash-table)))
(setf (gethash 1 hash-table) 100)
(setf (gethash 2 hash-table) 200)
(sort
(loop for key being each hash-key in hash-table using (hash-value val)
for key+1 = (1+ key)
collect (list key key+1 val))
#'<
:key #'car
) )
((1 2 100) (2 3 200)))
(my-assert
(loop for i across '#(1 2 3 4)
for j = (1+ i)
collect (list i j)
)
((1 2) (2 3) (3 4) (4 5)))
(my-assert
(loop for i in '()
for j = (1+ i)
collect j
)
nil)
(my-assert
(loop for i across '#()
for j = (1+ i)
collect j
)
nil)
(my-assert
(loop for x = t
for y in '(A B C)
for z = t
collect y
)
(A B C))
(my-assert
(loop for x = t
for y across '#(A B C)
for z = t
collect y
)
(A B C))
(my-assert
(loop for x = t
for y in ()
for z = t
collect y
)
nil)
(my-assert
(loop for x = t
for y across '#()
for z = t
collect y
)
nil)
(my-assert
(let ((hash-table (make-hash-table)))
(setf (gethash 1 hash-table) 100)
(setf (gethash 2 hash-table) 200)
(sort
(loop for x = t
for key being each hash-key in hash-table using (hash-value val)
for key+1 = (1+ key)
for z = t
collect (list key key+1 val))
#'<
:key #'car
) )
((1 2 100) (2 3 200)))
(my-assert
(loop for i from 1 to 0
collect i
)
nil)
(my-assert
(let ((hash-table (make-hash-table)))
(setf (gethash 1 hash-table) 100)
(setf (gethash 2 hash-table) 200)
(sort
(loop for val being each hash-value in hash-table
collect val)
#'<
) )
(100 200))
(my-assert
(let ((hash-table (make-hash-table)))
(setf (gethash 1 hash-table) 100)
(setf (gethash 2 hash-table) 200)
(sort
(loop for val being each hash-value in hash-table
for deriv-val = (/ 1 val)
collect deriv-val)
#'<
) )
(1/200 1/100))
(my-assert
(let ((hash-table (make-hash-table)))
(setq i 123456789)
(setf (gethash 1 hash-table) 100)
(setf (gethash 2 hash-table) 200)
(loop for i across '#(1 2 3 4 5 6)
collect i)
(loop for i in '(1 2 3 4 5 6)
collect i)
(loop for i being each hash-key of hash-table
collect i)
(loop for i being each present-symbol of *package*
collect i)
i
)
123456789)
(my-assert
(loop for x on '(3 4 5)
for y = (car x)
for z in '(a b c)
collect z
)
(a b c))
(my-assert
(loop for x across '#(3 4 5)
for y = (1+ x)
for z across '#(a b c)
collect (list x y z)
)
((3 4 a) (4 5 b) (5 6 c)))
(my-assert
(loop for x across '#()
for y = x
for z across '#(a b c)
collect (list x y z)
)
nil)
(my-assert
(loop for x across '#(1 2 3)
for y = x
for z across '#()
collect (list x y z)
)
nil)
(my-assert
(loop for x across '#(1 2 3)
for y = (1+ x)
for z across '#(a b)
collect (list x y z)
)
((1 2 a) (2 3 b)))
(my-assert
(loop for x across '#(1 2)
for y = (1+ x)
for z across '#(a b c)
collect (list x y z)
)
((1 2 a) (2 3 b)))
(my-assert
(let ((package (make-package "LOOP-TEST")))
(intern "blah" package)
(let ((blah2 (intern "blah2" package)))
(export blah2 package)
)
(list
(sort
(loop for sym being each present-symbol of package
for sym-name = (symbol-name sym)
collect sym-name
)
#'string<
)
(sort
(loop for sym being each external-symbol of package
for sym-name = (symbol-name sym)
collect sym-name
)
#'string<
) ) )
(("blah" "blah2") ("blah2")))
(my-assert
(let ((ht (make-hash-table)))
(loop for key being each hash-key of ht
for value = (gethash key ht)
collect (list key value)
) )
nil)
(my-assert
(let ((ht (make-hash-table)))
(loop for dummy = (+ 1 2)
for key being each hash-key of ht
collect (list key)
) )
nil)
;;; Three more tests, found by Russell Senior.
;;; They are justified by ANSI CL 6.1.1.4 and 6.1.2.1.5.
(my-assert
(let ((list '(1 2 3)))
(loop for x in list
and y = nil then x
collect (list x y)))
((1 NIL) (2 1) (3 2)))
(my-assert
(let ((list '(1 2 3)))
(loop for x in list
for y = nil then x
collect (list x y)))
((1 NIL) (2 2) (3 3)))
(my-assert
(let ((list '(1 2 3)))
(loop for x in list
for y = nil then x
and z = nil then y
collect (list x y z)))
((1 NIL NIL) (2 2 NIL) (3 3 2)))
;;; One more test, found by Lennart Staflin.
(my-assert
(loop repeat 4 for x = (+ 1 1) collect x)
(2 2 2 2))
;;; Tests from ANSI CL section 6.1.2.1.1.
(my-assert
(let ((x 1)) (loop for i from x by (incf x) to 10 collect i))
(1 3 5 7 9))
(my-assert
(let ((x 1)) (loop for i by (incf x) from x to 10 collect i))
(2 4 6 8 10)
"This should be the same as:
(let ((x 1)) (loop for i from x to 10 by (incf x) collect i))
it is legal to have by first:
arithmetic-up::= [[{from | upfrom} form1 | {to | upto | below} form2 | by form3]]+ ")
(my-assert
(loop for i from 1 to 5 collect i into c collect (copy-list c))
((1) (1 2) (1 2 3) (1 2 3 4) (1 2 3 4 5)))
;; Clean up.
(my-assert
(progn (delete-package "LOOP-TEST") t)
T)

141
src/ansi-tests/macro8.lisp Normal file
View file

@ -0,0 +1,141 @@
;;; based on v1.2 -*- mode: lisp -*-
(in-package :cl-user)
;; testen der macrofunktionen kapitel 8
;; ------------------------------------
;; 8.1
;; macro-function | defmacro
(my-assert
(and (macro-function 'push) T)
T)
(my-assert
(and (macro-function 'member) T)
NIL)
(my-assert
(defmacro arithmetic-if (test neg-form zero-form pos-form)
(let ((var (gensym)))
`(let ((,var ,test))
(cond ((< ,var 0) ,neg-form)
((= ,var 0) ,zero-form)
(T ,pos-form)))))
arithmetic-if)
(my-assert
(and (macro-function 'arithmetic-if) T)
T)
(my-assert
(setf x 8)
8)
(my-assert
(arithmetic-if (- x 4)(- x)(LIST "ZERO") x)
8)
(my-assert
(setf x 4)
4)
(my-assert
(arithmetic-if (- x 4)(- x)(LIST "ZERO")x)
("ZERO"))
(my-assert
(setf x 3)
3)
(my-assert
(arithmetic-if (- x 4)(- x)(LIST "ZERO")x)
-3)
(my-assert
(defmacro arithmetic-if (test neg-form &optional zero-form pos-form)
(let ((var (gensym)))
`(let ((,var ,test))
(cond ((< ,var 0) ,neg-form)
((= ,var 0) ,zero-form)
(T ,pos-form)))))
arithmetic-if)
(my-assert
(setf x 8)
8)
(my-assert
(arithmetic-if (- x 4)(- x))
nil)
(my-assert
(setf x 4)
4)
(my-assert
(arithmetic-if (- x 4)(- x))
NIL)
(my-assert
(setf x 3)
3)
(my-assert
(arithmetic-if (- x 4)(- x))
-3)
(my-assert
(defmacro halibut ((mouth eye1 eye2)
((fin1 length1)(fin2 length2))
tail)
`(list ,mouth ,eye1 ,eye2 ,fin1 ,length1 ,fin2 ,length2 ,tail))
halibut)
(my-assert
(setf m 'red-mouth
eyes '(left-eye . right-eye)
f1 '(1 2 3 4 5)
f2 '(6 7 8 9 0)
my-favorite-tail '(list of all parts of tail))
(list of all parts of tail))
(my-assert
(halibut (m (car eyes)(cdr eyes))
((f1 (length f1))(f2 (length f2)))
my-favorite-tail)
(RED-MOUTH LEFT-EYE RIGHT-EYE (1 2 3 4 5) 5 (6 7 8 9 0) 5
(LIST OF ALL PARTS OF TAIL)))
;; 8.2
;; macroexpand | macroexpand-1
(my-assert
(ecase 'otherwise
(otherwise 4))
4
"This is bad style, but perfectly legal!!")
;; Issue MACRO-FUNCTION-ENVIRONMENT:YES
(my-assert
(macrolet ((foo (&environment env)
(if (macro-function 'bar env)
''yes
''no)))
(list (foo)
(macrolet ((bar () :beep))
(foo))))
(no yes))

294
src/ansi-tests/map.lisp Normal file
View file

@ -0,0 +1,294 @@
;;; based on v1.2 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(setf a-vector (make-array 10))
#+(or XCL cmu sbcl) #(0 0 0 0 0 0 0 0 0 0)
#+(or CLISP AKCL ALLEGRO ecls) #(NIL NIL NIL NIL NIL NIL NIL NIL NIL NIL)
#-(or XCL CLISP AKCL ALLEGRO cmu sbcl ecls) UNKNOWN)
(my-assert
(do ((i 0 (1+ i))
(n (length a-vector)))
((= i n))
(when (null (aref a-vector i))
(setf (aref a-vector i) 0)))
nil)
(my-assert
(setq liste '(a b c d))
(a b c d))
(my-assert
(setq x 'anfangswert-von-x)
anfangswert-von-x)
(my-assert
(do ((x liste (cdr x))
(oldx x x))
((null x))
(print oldx) (print x))
nil)
(my-assert
(defun list-reverse(list)
(do ((x list (cdr x))
(y '() (cons (car x) y)))
((endp x) y)))
list-reverse)
(my-assert
(list-reverse '(a b c d))
(d c b a))
(my-assert
(setq foo '(a b c d))
(a b c d))
(my-assert
(setq bar '(1 2 3 4))
(1 2 3 4))
(my-assert
(defun fkt(a b) (cons a b))
fkt)
;; mapcar
(my-assert
(mapcar #'abs '(3 -4 2 -5 -6))
(3 4 2 5 6))
(my-assert
(mapcar #'cons '(a b c) '(1 2 3))
((a . 1) (b . 2) (c . 3)))
(my-assert
(mapcar #'fkt foo bar)
((a . 1)(b . 2)(c . 3)(d . 4)))
(my-assert
(do ((x foo (cdr x))
(y bar (cdr y))
(z '() (cons (fkt (car x) (car y)) z)))
((or (null x) (null y))
(nreverse z)))
((a . 1)(b . 2)(c . 3)(d . 4)))
;; dolist
(my-assert
(let ((l '(1 2 3))
(r 0))
(dolist (x l r)
(setf r (+ r x)) ))
6)
;; dolist
(my-assert
(let ((l '(1 2 3)))
(dolist (x l)(if (> 0 x)(incf x)(return 10))))
10)
(my-assert
(let ((l '(1 2 3)))
(dolist (x l )(incf x)))
nil)
;; dotimes
(my-assert
(let ((s 0))
(dotimes (i (+ 1 9)s)(setf s (+ s i))))
45)
(my-assert
(dolist (x '(a b c d)) (prin1 x) (princ " "))
nil)
(my-assert
(defun palindromep (string &optional
(start 0)
(end (length string)))
(dotimes (k (floor (- end start) 2) t)
(unless (char-equal (char string (+ start k))
(char string (- end k 1)))
(return nil))))
palindromep)
(my-assert
(palindromep "Able was I ere I saw Elba")
t)
(my-assert
(palindromep "einnegermitgazellezagtimregennie")
t)
(my-assert
(palindromep "eisgekuehlter bommerlunder")
nil)
(my-assert
(palindromep (remove-if-not #'alpha-char-p
"A man, a plan, a canal -- Panama"))
t)
(my-assert
(MAPCAR (FUNCTION (LAMBDA (X) (LIST X))) (QUOTE (A B C)))
((A) (B) (C)))
(my-assert
(MAPCAR (FUNCTION (LAMBDA (X Y) (LIST X Y))) (QUOTE (A B C)) (QUOTE
(1 2 3)))
((A 1) (B 2) (C 3)))
(my-assert
(MAPCAR (FUNCTION (LAMBDA (X Y) (LIST X Y))) (QUOTE (A B C)) (QUOTE
(1 2)))
((A 1) (B 2)))
(my-assert
(MAPCAR (FUNCTION (LAMBDA (X Y) (LIST X Y))) (QUOTE (C)) (QUOTE (1
2)))
((C 1)))
(my-assert
(MAPCAR (FUNCTION (LAMBDA (X Y Z) (LIST X Y))) (QUOTE (C)) (QUOTE (1
2)) (U V W))
ERROR)
(my-assert
(MAPCAR (FUNCTION (LAMBDA (X Y Z) (LIST X Y))) (QUOTE (C)) (QUOTE (1
2))
(QUOTE (U V W)))
((C 1)))
(my-assert
(MAPCAR (FUNCTION (LAMBDA (X Y Z) (LIST X Y))) (QUOTE (A B C)) (QUOTE
(1 2 3))
(QUOTE (U V W)))
((A 1) (B 2) (C 3)))
(my-assert
(MAPCAR (FUNCTION (LAMBDA (X Y Z) (LIST X Y Z))) (QUOTE (A B C)) (QUOTE
(1 2 3))
(QUOTE (U V W)))
((A 1 U) (B 2 V) (C 3 W)))
;; mapc
(my-assert
(mapc #'abs '(3 -4 2 -5 -6))
(3 -4 2 -5 -6))
(my-assert
(MAPC (FUNCTION (LAMBDA (X Y Z) (LIST X Y Z))) (QUOTE (A B C)) (QUOTE
(1 2 3))
(QUOTE (U I V)))
(A B C))
(my-assert
(MAPCAR (FUNCTION (LAMBDA (X Y Z) (LIST X Y Z))) (QUOTE (A B C)) (QUOTE
(1 2 3))
(QUOTE (U I V)))
((A 1 U) (B 2 I) (C 3 V)))
(my-assert
(mapl #'(lambda (x y)(cons x y))'(a b c d)'(1 2 3 4))
(a b c d))
(my-assert
(MAPL (FUNCTION (LAMBDA (X Y Z) (LIST X Y Z))) (QUOTE (A B C)) (QUOTE
(1 2 3))
(QUOTE (U I V)))
(A B C))
;; maplist
(my-assert
(maplist #'(lambda (x)(cons 'foo x))'(a b c d))
((foo a b c d)(foo b c d)(foo c d)(foo d)))
(my-assert
(maplist #'(lambda (x) (if (member (car x)(cdr x)) 0 1))
'(a b a c d b c))
(0 0 1 0 1 1 1))
(my-assert
(MAPLIST (FUNCTION (LAMBDA (X Y Z) (LIST X Y Z))) (QUOTE (A B C))
(QUOTE (1 2 3)) (QUOTE (U I V)))
(((A B C) (1 2 3) (U I V)) ((B C) (2 3) (I V)) ((C) (3) (V))))
(my-assert
(MAPLIST (FUNCTION (LAMBDA (X Y Z) (LIST X Y Z))) (QUOTE (A B C))
(QUOTE (1 2 3)) (QUOTE (U I)))
(((A B C) (1 2 3) (U I)) ((B C) (2 3) (I))))
(my-assert
(MAPLIST (FUNCTION (LAMBDA (X Y Z) (LIST X Y Z))) (QUOTE (A B C)) (QUOTE
(1 2))
(QUOTE (U I V)))
(((A B C) (1 2) (U I V)) ((B C) (2) (I V))))
(my-assert
(MAPLIST (FUNCTION (LAMBDA (X Y Z) (LIST X Y Z))) (QUOTE (A B)) (QUOTE
(1 2 3))
(QUOTE (U I V)))
(((A B) (1 2 3) (U I V)) ((B) (2 3) (I V))))
;; mapcon
(my-assert
(mapcon #'(lambda (x)(and (oddp (car x))(list (car x))))'(5 4 3 2 1))
(5 3 1))
(my-assert
(MAPCON (FUNCTION (LAMBDA (X Y Z) (LIST X Y Z))) (QUOTE (A B)) (QUOTE
(1 2 3))
(QUOTE (U I V)))
((A B) (1 2 3) (U I V) (B) (2 3) (I V)))
(my-assert
(MAPCON (FUNCTION (LAMBDA (X Y Z) (LIST X Y Z))) (QUOTE (A B C)) (QUOTE
(1 2 3))
(QUOTE (U I V)))
((A B C) (1 2 3) (U I V) (B C) (2 3) (I V) (C) (3) (V)))
;; mapcan
(my-assert
(mapcan #'(lambda (x)(and (numberp x)(list x)))'(a 1 b c 3 4 d 5))
(1 3 4 5))
(my-assert
(MAPCAN (FUNCTION (LAMBDA (X Y Z) (LIST X Y Z))) (QUOTE (A B C)) (QUOTE
(1 2 3))
(QUOTE (U I V)))
(A 1 U B 2 I C 3 V))
(my-assert
(MAPCAN (FUNCTION (LAMBDA (X Y) (LIST X Y))) (QUOTE (A B C)) (QUOTE
(1 2 3)))
(A 1 B 2 C 3))
(my-assert
(MAPCAN (FUNCTION (LAMBDA (X) (LIST X))) (QUOTE (A B C)))
(A B C))
(my-assert
(MAPCON (FUNCTION (LAMBDA (X) (LIST X))) (QUOTE (A B C)))
((A B C) (B C) (C)))
(my-assert
(MAPCON (FUNCTION (LAMBDA (X Y) (LIST X Y))) (QUOTE (A B C)) (QUOTE
(1 2)))
((A B C) (1 2) (B C) (2)))
(my-assert
(MAPCON (FUNCTION (LAMBDA (X) (LIST X))) (QUOTE (A B C)))
((A B C) (B C) (C)))

34
src/ansi-tests/mop.lisp Normal file
View file

@ -0,0 +1,34 @@
;;; based on v1.1.1.1 -*- mode: lisp -*-
(in-package :cl-user)
;; Test some MOP-like CLOS features
#+clisp
(my-assert
(progn
(defstruct rectangle1 (x 0.0) (y 0.0))
(defclass counted1-class (structure-class)
((counter :initform 0)) #+CLISP (:metaclass structure-class))
(defclass counted1-rectangle (rectangle1) () (:metaclass counted1-class))
(defmethod make-instance :after ((c counted1-class) &rest args)
(incf (slot-value c 'counter)))
(slot-value (find-class 'counted1-rectangle) 'counter)
(make-instance 'counted1-rectangle)
(slot-value (find-class 'counted1-rectangle) 'counter)
)
1)
#+clisp
(my-assert
(progn
(defclass rectangle2 ()
((x :initform 0.0 :initarg x) (y :initform 0.0 :initarg y)))
(defclass counted2-class (standard-class)
((counter :initform 0)) #+CLISP (:metaclass structure-class))
(defclass counted2-rectangle (rectangle2) () (:metaclass counted2-class))
(defmethod make-instance :after ((c counted2-class) &rest args)
(incf (slot-value c 'counter)))
(slot-value (find-class 'counted2-rectangle) 'counter)
(make-instance 'counted2-rectangle)
(slot-value (find-class 'counted2-rectangle) 'counter)
)
1)

37
src/ansi-tests/new-bugs.lisp Normal file
View file

@ -0,0 +1,37 @@
;;; -*- mode: lisp -*-
(proclaim '(special log))
(in-package :cl-user)
;; From: Gary Bunting <gbunting@cantor.une.edu.au>
(my-assert
(setf xx (expt 3 32))
1853020188851841)
(my-assert
(* xx xx)
3433683820292512484657849089281)
;; paul
(my-assert
(defun bugged (x)
(labels ((f (y &optional trouble) ; <<< or &key or &rest ..
(if y
(let ((a (pop y)))
(f a)))))))
BUGGED)
(my-assert
(defun tst ()
(labels
((eff (&key trouble)
(eff)
))
;;(eff :trouble nil) ;<< this works
(eff);; << this causes assert failure
))
tst)

14696
src/ansi-tests/number.lisp Normal file
View file

File diff suppressed because it is too large Load diff

35
src/ansi-tests/number2.lisp Normal file
View file

@ -0,0 +1,35 @@
;;; based on v1.4 -*- mode: lisp -*-
(in-package :user)
(my-assert
(gcd 2346026393680644703525505657 17293822570713318399)
11)
(my-assert
(multiple-value-list (xgcd 77874422 32223899))
(1 -9206830 22249839))
(my-assert
(multiple-value-list (xgcd 560014183 312839871))
(1 77165803 -138134388))
(my-assert
(multiple-value-list (xgcd 3 2))
(1 1 -1))
(my-assert
(multiple-value-list (xgcd 2 3))
(1 -1 1))
(my-assert
(let ((a 974507656412513757857315037382926980395082974811562770185617915360)
(b -1539496810360685510909469177732386446833404488164283))
(multiple-value-bind (g u v) (xgcd a b)
(and (eql g 1) (eql g (+ (* a u) (* b v))))
) )
T)
(my-assert
(isqrt #x3FFFFFFFC000000000007F)
#x7FFFFFFFBFF)

583
src/ansi-tests/path.lisp Normal file
View file

@ -0,0 +1,583 @@
;;; based on v1.2 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(setf string "test-pathname.abc" symbol 'test-pathname.abc)
test-pathname.abc)
;;pathname -mögl. Argumenttypen: pathname,string,symbol,stream
;; -resultat: pathname
(my-assert
(SETF PATHSTRING (PATHNAME STRING))
#+XCL
#S(PATHNAME SYSTEM::HOST NIL
SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "TEST-PATHNAME"
TYPE "ABC" SYSTEM::VERSION NIL)
#+CLISP
#S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY (:RELATIVE)
:NAME "test-pathname" :TYPE "abc" :VERSION NIL))
(my-assert
(SETF PATHSYMBOL (PATHNAME symbol))
#+XCL
#S(PATHNAME SYSTEM::HOST
NIL SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME
"TEST-PATHNAME" TYPE "ABC" SYSTEM::VERSION NIL)
#+CLISP
#S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY (:RELATIVE)
:NAME "test-pathname" :TYPE "abc" :VERSION NIL))
(my-assert
(SETF PATHPATH (PATHNAME PATHSYMBOL))
#+XCL
#S(PATHNAME SYSTEM::HOST NIL
SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "TEST-PATHNAME"
TYPE "ABC" SYSTEM::VERSION NIL)
#+CLISP
#S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY (:RELATIVE)
:NAME "test-pathname" :TYPE "abc" :VERSION NIL))
(my-assert
(SETF STREAM (OPEN STRING :DIRECTION :OUTPUT)
a nil)
nil)
;; (SETF PATHSTREAM (PATHNAME STREAM))
;; "test-pathname.lsp"
(my-assert
(MAPCAR (FUNCTION PATHNAMEP)
(LIST PATHSTRING PATHSYMBOL PATHPATH ;PATHSTREAM
))
(T T T ;T
))
;; funktion truename liefert filename fuer pathname oder stream
;; einen Pfadnamen
;;
;; (MAPCAR (FUNCTION TRUENAME) (LIST PATHSTRING PATHSYMBOL PATHPATH STREAM
;; ;PATHSTREAM
;; ))
;; ERROR
(my-assert
(PARSE-NAMESTRING STRING)
#+XCL
#S(PATHNAME SYSTEM::HOST NIL
SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "TEST-PATHNAME"
TYPE "ABC" SYSTEM::VERSION NIL)
#+CLISP
#S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY (:RELATIVE)
:NAME "test-pathname" :TYPE "abc" :VERSION NIL))
(my-assert
(PARSE-NAMESTRING SYMBOL)
#+XCL
#S(PATHNAME SYSTEM::HOST NIL
SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "TEST-PATHNAME"
TYPE "ABC" SYSTEM::VERSION NIL)
#+CLISP
#S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY (:RELATIVE)
:NAME "test-pathname" :TYPE "abc" :VERSION NIL))
#+XCL
(my-assert
(PARSE-NAMESTRING "bab:test-pathname.abc")
#S(PATHNAME SYSTEM::HOST NIL
SYSTEM::DEVICE "$1$DUA70" DIRECTORY "43.BABYLON.REL2" SYSTEM::NAME
"TEST-PATHNAME" TYPE "ABC" SYSTEM::VERSION NIL))
#+XCL
(my-assert
(PARSE-NAMESTRING "bab:test-pathname.abc;3")
#S(PATHNAME SYSTEM::HOST NIL
SYSTEM::DEVICE "$1$DUA70" DIRECTORY "43.BABYLON.REL2" SYSTEM::NAME
"TEST-PATHNAME" TYPE "ABC" SYSTEM::VERSION 3))
(my-assert
(PARSE-NAMESTRING PATHSTRING)
#+XCL
#S(PATHNAME SYSTEM::HOST NIL SYSTEM::DEVICE
"DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "TEST-PATHNAME" TYPE "ABC"
SYSTEM::VERSION NIL)
#+CLISP
#S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY (:RELATIVE)
:NAME "test-pathname" :TYPE "abc" :VERSION NIL))
(my-assert
(PARSE-NAMESTRING "test-pathname.abc" NIL)
#+XCL
#S(PATHNAME SYSTEM::HOST NIL
SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "TEST-PATHNAME"
TYPE "ABC" SYSTEM::VERSION NIL)
#+CLISP
#S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY (:RELATIVE)
:NAME "test-pathname" :TYPE "abc" :VERSION NIL))
#+XCL
(my-assert
(PARSE-NAMESTRING "sirius::disk00$abt43:[heicking]test-pathname.abc")
#S(PATHNAME
SYSTEM::HOST "SIRIUS" SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "HEICKING"
SYSTEM::NAME "TEST-PATHNAME" TYPE "ABC" SYSTEM::VERSION NIL))
#+XCL
(my-assert
(PARSE-NAMESTRING "sirius::disk00$abt43:[heicking]test-pathname.abc" "sirius")
#S(PATHNAME
SYSTEM::HOST "SIRIUS" SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "HEICKING"
SYSTEM::NAME "TEST-PATHNAME" TYPE "ABC" SYSTEM::VERSION NIL))
#+XCL
(my-assert
(PARSE-NAMESTRING "sirius::disk00$abt43:[heicking]test-pathname.abc" "orion")
ERROR)
(my-assert
(PARSE-NAMESTRING "abc.123" NIL NIL :START 0 :END 5)
#+XCL
#S(PATHNAME SYSTEM::HOST
NIL SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "ABC" TYPE
"1" SYSTEM::VERSION NIL)
#+CLISP
#S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY (:RELATIVE)
:NAME "abc" :TYPE "1" :VERSION NIL))
(my-assert
(PARSE-NAMESTRING "abc.123" NIL NIL :START 2 :END 5)
#+XCL
#S(PATHNAME SYSTEM::HOST
NIL SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "C" TYPE "1"
SYSTEM::VERSION NIL)
#+CLISP
#S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY (:RELATIVE)
:NAME "c" :TYPE "1" :VERSION NIL))
#+XCL
(my-assert
(PARSE-NAMESTRING "babylon" NIL NIL :START 0 :END 3)
#S(PATHNAME SYSTEM::HOST
NIL SYSTEM::DEVICE "$1$DUA70" DIRECTORY "43.BABYLON.REL2" SYSTEM::NAME NIL TYPE
NIL SYSTEM::VERSION NIL))
#+XCL
(my-assert
(PARSE-NAMESTRING "babylon" NIL NIL :START 0 :END 7)
#S(PATHNAME SYSTEM::HOST
NIL SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "BABYLON"
TYPE NIL SYSTEM::VERSION NIL))
#+XCL
(my-assert
(PARSE-NAMESTRING "babylon" NIL *DEFAULT-PATHNAME-DEFAULTS* :START 0 :END 7)
#S(PATHNAME
SYSTEM::HOST NIL SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME
"BABYLON" TYPE NIL SYSTEM::VERSION NIL))
(my-assert
*DEFAULT-PATHNAME-DEFAULTS*
#+XCL
#S(PATHNAME SYSTEM::HOST NIL SYSTEM::DEVICE NIL
DIRECTORY NIL SYSTEM::NAME NIL TYPE "lsp" SYSTEM::VERSION :NEWEST)
#+(and CLISP (or win32 os2))
#S(PATHNAME :HOST NIL :DEVICE "C" :DIRECTORY (:RELATIVE)
:NAME NIL :TYPE NIL :VERSION NIL)
#+(and CLISP unix)
#S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY (:RELATIVE)
:NAME NIL :TYPE NIL :VERSION NIL))
#+XCL
(my-assert
(PARSE-NAMESTRING "babylon" NIL *DEFAULT-PATHNAME-DEFAULTS* :START 0 :END 3)
#S(PATHNAME
SYSTEM::HOST NIL SYSTEM::DEVICE "$1$DUA70" DIRECTORY "43.BABYLON.REL2"
SYSTEM::NAME NIL TYPE NIL SYSTEM::VERSION NIL))
;; (PARSE-NAMESTRING "babylon.c.c" NIL NIL :JUNK-ALLOWED T)
;; #S(PATHNAME
;; SYSTEM::HOST NIL SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME
;; "BABYLON" TYPE "C" SYSTEM::VERSION NIL)
;; (PARSE-NAMESTRING "babylon;c.c" NIL NIL :JUNK-ALLOWED T)
;; #S(PATHNAME
;; SYSTEM::HOST NIL SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME
;; "BABYLON" TYPE NIL SYSTEM::VERSION NIL)
#+XCL
(my-assert
(PARSE-NAMESTRING "babylon;c.c" NIL NIL :JUNK-ALLOWED NIL)
ERROR)
#+XCL
(my-assert
(PARSE-NAMESTRING "babylon.c.c" NIL NIL :JUNK-ALLOWED NIL)
ERROR)
#+XCL
(my-assert
(PARSE-NAMESTRING "babylon.c;c" NIL NIL :JUNK-ALLOWED NIL)
ERROR)
#+XCL
(my-assert
(PARSE-NAMESTRING "babylon.c;" NIL NIL :JUNK-ALLOWED NIL)
#S(PATHNAME
SYSTEM::HOST NIL SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME
"BABYLON" TYPE "C" SYSTEM::VERSION NIL))
#+XCL
(my-assert
(PARSE-NAMESTRING "babylon.c;5" NIL NIL :JUNK-ALLOWED NIL)
#S(PATHNAME
SYSTEM::HOST NIL SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME
"BABYLON" TYPE "C" SYSTEM::VERSION 5))
;; (MERGE-PATHNAME "test$$" SYMBOL 10) ERROR
;;
;; (MERGE-PATHNAME "test$$" SYMBOL) ERROR
;;
;; (MERGE-PATHNAME "test$$" PATH) ERROR
;;
;; (MERGE-PATHNAME "test$$") ERROR
#+XCL
(my-assert
(MERGE-PATHNAMES "test$$")
#S(PATHNAME SYSTEM::HOST NIL SYSTEM::DEVICE
"DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "TEST$$" TYPE "lsp"
SYSTEM::VERSION :NEWEST))
#+XCL
(my-assert
(MERGE-PATHNAMES "test$$" SYMBOL)
#S(PATHNAME SYSTEM::HOST NIL SYSTEM::DEVICE
"DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "TEST$$" TYPE "ABC"
SYSTEM::VERSION :NEWEST))
#+XCL
(my-assert
(MERGE-PATHNAMES "test$$" SYMBOL 2)
#S(PATHNAME SYSTEM::HOST NIL
SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "TEST$$" TYPE
"ABC" SYSTEM::VERSION 2))
#+XCL
(my-assert
(MERGE-PATHNAMES "test$$" (PATHNAME SYMBOL) 2)
#S(PATHNAME SYSTEM::HOST NIL
SYSTEM::DEVICE "DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "TEST$$" TYPE
"ABC" SYSTEM::VERSION 2))
#+XCL
(my-assert
(MERGE-PATHNAMES "test$$" STREAM 2)
#S(PATHNAME SYSTEM::HOST 16 SYSTEM::DEVICE
"DISK00$ABT43" DIRECTORY "XCL.MAIN" SYSTEM::NAME "TEST$$" TYPE :ESCAPE
SYSTEM::VERSION 2))
;; (MERGE-PATHNAME STRING SYMBOL) ERROR
#+XCL
(my-assert
(MAKE-PATHNAME :NAME "a" :HOST (QUOTE ORION))
#S(PATHNAME SYSTEM::HOST ORION
SYSTEM::DEVICE NIL DIRECTORY NIL SYSTEM::NAME "a" TYPE NIL SYSTEM::VERSION
:NEWEST))
#+XCL
(my-assert
(DEFMACRO TEST (&REST BODY) (\` (APPLY (FUNCTION MAKE-PATHNAME) (\,@ BODY))))
TEST)
#+XCL
(my-assert
(setf a '(:host "sirius" :name "a"))
(:host "sirius" :name "a"))
#+XCL
(my-assert
(TEST A)
#S(PATHNAME SYSTEM::HOST "sirius" SYSTEM::DEVICE NIL DIRECTORY NIL
SYSTEM::NAME "a" TYPE NIL SYSTEM::VERSION :NEWEST))
#+XCL
(my-assert
(SETF A (LIST* :DEVICE "disk00$abt43" A))
(:DEVICE "disk00$abt43" :HOST "sirius" :NAME "a"))
#+XCL
(my-assert
(TEST A)
#S(PATHNAME SYSTEM::HOST "sirius" SYSTEM::DEVICE "disk00$abt43"
DIRECTORY NIL SYSTEM::NAME "a" TYPE NIL SYSTEM::VERSION :NEWEST))
#+XCL
(my-assert
(SETF A (LIST* :DIRECTORY "[heicking.comlisp]" A))
(:DIRECTORY
"[heicking.comlisp]" :DEVICE "disk00$abt43" :HOST "sirius" :NAME "a"))
#+XCL
(my-assert
(TEST A)
#S(PATHNAME SYSTEM::HOST "sirius" SYSTEM::DEVICE "disk00$abt43"
DIRECTORY "[heicking.comlisp]" SYSTEM::NAME "a" TYPE NIL SYSTEM::VERSION
:NEWEST))
#+XCL
(my-assert
(SETF A (LIST* :TYPE "raf" A))
(:TYPE "raf" :DIRECTORY "[heicking.comlisp]"
:DEVICE "disk00$abt43" :HOST "sirius" :NAME "a"))
#+XCL
(my-assert
(TEST A)
#S(PATHNAME SYSTEM::HOST "sirius" SYSTEM::DEVICE "disk00$abt43"
DIRECTORY "[heicking.comlisp]" SYSTEM::NAME "a" TYPE "raf" SYSTEM::VERSION
:NEWEST))
#+XCL
(my-assert
(SETF A (LIST* :VERSION 3 A))
(:VERSION 3 :TYPE "raf" :DIRECTORY
"[heicking.comlisp]" :DEVICE "disk00$abt43" :HOST "sirius" :NAME "a"))
#+XCL
(my-assert
(TEST A)
#S(PATHNAME SYSTEM::HOST "sirius" SYSTEM::DEVICE "disk00$abt43"
DIRECTORY "[heicking.comlisp]" SYSTEM::NAME "a" TYPE "raf" SYSTEM::VERSION 3))
(my-assert
(MAPCAR (FUNCTION PATHNAMEP) (LIST PATHSYMBOL PATHPATH PATHSTRING))
(T T T))
#+XCL
(my-assert
(SETF PATH (TEST A))
#S(PATHNAME SYSTEM::HOST "sirius" SYSTEM::DEVICE
"disk00$abt43" DIRECTORY "[heicking.comlisp]" SYSTEM::NAME "a" TYPE "raf"
SYSTEM::VERSION 3))
#+XCL
(my-assert
(MAPCAR (FUNCTION PATHNAME-HOST) (LIST SYMBOL STRING STREAM PATH))
(NIL NIL NIL NIL))
#+XCL
(my-assert
(MAPCAR (FUNCTION PATHNAME-DEVICE) (LIST SYMBOL STRING STREAM PATH))
("DISK00$ABT43" "DISK00$ABT43" "DISK00$ABT43" "DISK00$ABT43"))
#+XCL
(my-assert
(MAPCAR (FUNCTION PATHNAME-DIRECTORY) (LIST SYMBOL STRING STREAM PATH))
("XCL.MAIN" "XCL.MAIN" "XCL.MAIN" "XCL.MAIN"))
(my-assert
(PROGN (CLOSE STREAM) T)
T)
#+XCL
(my-assert
(USER-HOMEDIR-PATHNAME)
#S(PATHNAME SYSTEM::HOST NIL SYSTEM::DEVICE
"DISK00$ABT43" DIRECTORY "HEICKING" SYSTEM::NAME NIL TYPE NIL SYSTEM::VERSION
NIL))
(my-assert
(PATHNAME "*.*")
#+XCL
#S(PATHNAME SYSTEM::HOST NIL SYSTEM::DEVICE "DISK00$ABT43"
DIRECTORY "HEICKING" SYSTEM::NAME "*" TYPE :WILD SYSTEM::VERSION NIL)
#+CLISP
#S(PATHNAME :HOST NIL :DEVICE NIL :DIRECTORY (:RELATIVE)
:NAME :WILD :TYPE :WILD :VERSION NIL)
#-(or XCL CLISP)
#P"*.*")
(my-assert
(progn (setf file (open "nicht-vorhandenes-file.non"
:direction :input
:element-type 'character
:if-does-not-exist :create)) t)
t
"")
(my-assert
(null (probe-file "nicht-vorhandenes-file.non"))
NIL)
(my-assert
(progn (close file) t)
t)
(my-assert
(setf file (open "nicht-vorhandenes-file.non"
:direction :io
:element-type 'string-char
:if-exists :error))
error)
(my-assert
(progn (close file) t)
t)
(my-assert
(null (setf file (open "nicht-vorhandenes-file.non"
:direction :io
:element-type 'character
:if-exists :new-version)))
nil
"")
(my-assert
(progn (close file) t)
t)
(my-assert
(null (setf file (open "nicht-vorhandenes-file.non"
:direction :io
:element-type 'character
:if-exists :rename)))
nil)
(my-assert
(progn (close file) t)
t)
(my-assert
(null (setf file (open "nicht-vorhandenes-file.non"
:direction :io
:element-type 'character
:if-exists :rename-and-delete)))
nil)
(my-assert
(progn (close file) t)
t)
(my-assert
(null (setf file (open "nicht-vorhandenes-file.non"
:direction :io
:element-type 'character
:if-exists :overwrite)))
nil)
(my-assert
(progn (close file) t)
t)
(my-assert
(null (setf file (open "nicht-vorhandenes-file.non"
:direction :io
:element-type 'character
:if-exists :append)))
nil)
(my-assert
(progn (close file) t)
t)
(my-assert
(null (setf file (open "nicht-vorhandenes-file.non"
:direction :io
:element-type 'character
:if-exists :supersede)))
nil)
(my-assert
(progn (close file) t)
t)
(my-assert
(setf file (open "nicht-vorhandenes-file.non"
:direction :io
:element-type 'character
:if-exists nil))
nil)
(my-assert
(progn (close file) t)
error)
(my-assert
(setf file (open "nicht-vorhandenes-file.new"
:direction :io
:element-type 'character
:if-does-not-exist :error))
error)
(my-assert
(progn (close file) t)
error)
(my-assert
(null (setf file (open "nicht-vorhandenes-file.new"
:direction :io
:element-type 'character
:if-does-not-exist :create)))
nil)
(my-assert
(progn (close file) t)
t)
(my-assert
(null (setf file (open "nicht-vorhandenes-file.non"
:direction :io
:element-type 'character
:if-does-not-exist nil)))
nil)
(my-assert
(progn (close file) t)
t)
(my-assert
(namestring
(multiple-value-setq (new-name pathname truename)
(rename-file "nicht-vorhandenes-file.non" "file.da")))
"file.da")
(my-assert
(namestring new-name)
"file.da")
(my-assert
(null pathname)
nil)
(my-assert
(null truename)
nil)
(my-assert
(progn (delete-file "test-pathname.abc") t)
t)
(my-assert
(progn (mapc #'delete-file (directory "nicht-vorhandenes-file.*")) t)
t)
(my-assert
(progn (delete-file "file.da") t)
t)
(my-assert
(progn
(setf (logical-pathname-translations "clocc")
'(("**;*" "/usr/local/src/clocc/**/*")))
nil)
nil)
(my-assert
(translate-logical-pathname "clocc:src;port;")
#P"/usr/local/src/clocc/src/port/")

651
src/ansi-tests/readtable.lisp Normal file
View file

@ -0,0 +1,651 @@
;;; based on v1.1.1.1 -*- mode: lisp -*-
(in-package :cl-user)
;; ****************************************************************************
;; * Rosenmueller tel.340 Testquelle READTABLE.que 23.03.1988 *
;; ****************************************************************************
(my-assert
(prin1-to-string (setq *readtable* (copy-readtable nil)))
"#<SYSTEM::%TYPE-READTABLE #<SYSTEM::%TYPE-SIMPLE-VECTOR SYSTEM::%TYPE-UNSIGNED-WORD-POINTER
00000000 00000000 00000000 00000000 00040001 00000004 00040004 00000000
00000000 00000000 00000000 00000000 00000000 00000000 00000000 00000000
00010004 011E0075 00010001 02250001 00A50395 0C010401 14010535 00010B41
06010601 06010601 06010601 06010601 06010601 00850701 08010001 00010001
0D010061 12010E01 00011501 00010001 00010001 00010001 00010001 0F010001
00010001 13011101 00010001 00010001 00011001 00010001 00010902 00010001
0D010055 12010E01 00011501 00010001 00010001 00010001 00010001 0F010001
00010001 13011101 00010001 00010001 00011001 00C50001 00B50A03 00010001>
NIL>")
(my-assert
(setq $ 23)
23)
(my-assert
(defun single-dollar-reader (stream char)
(declare (ignore stream))
(intern (string char)))
SINGLE-DOLLAR-READER)
(my-assert
(set-macro-character #\$ #'single-dollar-reader)
T)
(my-assert
$
23)
(my-assert
45
45
;; => 23 => 45
(prin1-to-string (get-macro-character #\$))
"#<SYSTEM::%TYPE-CLOSURE SINGLE-DOLLAR-READER
NIL
NIL
(LAMBDA (STREAM CHAR) (DECLARE (IGNORE STREAM)) (INTERN (STRING CHAR)))>")
(my-assert
(progn (setq *readtable* (copy-readtable nil)) t)
t)
(my-assert
(sys::rt-bitmask-char #\" )
117)
(my-assert
(sys::rt-bitmask-char #\( )
917)
(my-assert
(sys::rt-bitmask-char #\) )
165)
(my-assert
(sys::rt-bitmask-char #\\ )
2306)
(my-assert
(sys::rt-bitmask-char #\x )
4097)
(my-assert
(sys::rt-bitmask-char #\y )
1)
(my-assert
(set-syntax-from-char #\" #\( )
T)
(my-assert
(sys::rt-bitmask-char #\" )
917)
(my-assert
(sys::rt-bitmask-char #\( )
917)
(my-assert
(sys::rt-bitmask-char #\) )
165)
(my-assert
(sys::rt-bitmask-char #\\ )
2306
;; *readtable* nil
;; *readtable* cl-standard
(progn (setq doppelquote-liston-readtable (copy-readtable)) t)
t)
(my-assert
(sys::rt-bitmask-char #\" doppelquote-liston-readtable )
917)
(my-assert
(sys::rt-bitmask-char #\( doppelquote-liston-readtable )
917)
(my-assert
(sys::rt-bitmask-char #\) doppelquote-liston-readtable )
165)
(my-assert
(sys::rt-bitmask-char #\\ doppelquote-liston-readtable )
2306)
(my-assert
'"1 2 3)
(1 2 3))
(my-assert
(set-syntax-from-char #\" #\\ )
T)
(my-assert
(sys::rt-bitmask-char #\" )
2306)
(my-assert
(sys::rt-bitmask-char #\( )
917)
(my-assert
(sys::rt-bitmask-char #\) )
165)
(my-assert
(sys::rt-bitmask-char #\\ )
2306)
(my-assert
(progn (setq doppelquote-backslash-readtable (copy-readtable)) t)
T)
(my-assert
(sys::rt-bitmask-char #\" doppelquote-backslash-readtable )
2306)
(my-assert
(sys::rt-bitmask-char #\\ doppelquote-backslash-readtable )
2306)
(my-assert
(sys::rt-bitmask-char #\( doppelquote-backslash-readtable )
917)
(my-assert
(sys::rt-bitmask-char #\) doppelquote-backslash-readtable )
165)
(my-assert
#"<
#\<)
(my-assert
(progn (setq 2.-doppelquote-backslash-readtable
(copy-readtable doppelquote-backslash-readtable)) t)
t)
(my-assert
(sys::rt-bitmask-char #\" 2.-doppelquote-backslash-readtable )
2306)
(my-assert
(sys::rt-bitmask-char #\\ 2.-doppelquote-backslash-readtable )
2306)
(my-assert
(sys::rt-bitmask-char #\( 2.-doppelquote-backslash-readtable )
917)
(my-assert
(sys::rt-bitmask-char #\) 2.-doppelquote-backslash-readtable )
165)
(my-assert
(progn (setq 2.-doppelquote-liston-readtable
(copy-readtable doppelquote-liston-readtable)) t)
t)
(my-assert
(sys::rt-bitmask-char #\" 2.-doppelquote-liston-readtable )
917)
(my-assert
(sys::rt-bitmask-char #\( 2.-doppelquote-liston-readtable )
917)
(my-assert
(sys::rt-bitmask-char #\) 2.-doppelquote-liston-readtable )
165)
(my-assert
(sys::rt-bitmask-char #\\ 2.-doppelquote-liston-readtable )
2306)
(my-assert
(progn (setq cl-standard-readtable
(copy-readtable nil))
(setq *readtable* cl-standard-readtable) t)
t)
(my-assert
(sys::rt-bitmask-char #\" cl-standard-readtable )
117)
(my-assert
(sys::rt-bitmask-char #\( cl-standard-readtable )
917)
(my-assert
(sys::rt-bitmask-char #\) cl-standard-readtable )
165)
(my-assert
(sys::rt-bitmask-char #\\ cl-standard-readtable )
2306)
(my-assert
(sys::rt-bitmask-char #\" )
117)
(my-assert
(sys::rt-bitmask-char #\( )
917)
(my-assert
(sys::rt-bitmask-char #\) )
165)
(my-assert
(sys::rt-bitmask-char #\\ )
2306)
(my-assert
"1234"
"1234")
(my-assert
(progn (setq *readtable* 2.-doppelquote-liston-readtable) t)
t)
(my-assert
(sys::rt-bitmask-char #\" )
917)
(my-assert
(sys::rt-bitmask-char #\( )
917)
(my-assert
(sys::rt-bitmask-char #\) )
165)
(my-assert
(sys::rt-bitmask-char #\\ )
2306)
(my-assert
'"1 2 3)
(1 2 3)
(progn (setq *readtable* doppelquote-backslash-readtable) t)
T
(sys::rt-bitmask-char #\" )
2306
(sys::rt-bitmask-char #\( )
917
(sys::rt-bitmask-char #\) )
165
(sys::rt-bitmask-char #\\ )
2306
#"<
#\<)
(my-assert
(readtablep 2.-doppelquote-backslash-readtable )
T)
(readtablep 1)
NIL
(set-syntax-from-char #\" #\" 2.-doppelquote-backslash-readtable )
T
(sys::rt-bitmask-char #\" 2.-doppelquote-backslash-readtable )
117
(sys::rt-bitmask-char #\\ 2.-doppelquote-backslash-readtable )
2306
(sys::rt-bitmask-char #\( 2.-doppelquote-backslash-readtable )
917
(sys::rt-bitmask-char #\) 2.-doppelquote-backslash-readtable )
165
(set-syntax-from-char #\) #\( 2.-doppelquote-backslash-readtable )
T
(sys::rt-bitmask-char #\" 2.-doppelquote-backslash-readtable )
117
(sys::rt-bitmask-char #\\ 2.-doppelquote-backslash-readtable )
2306
(sys::rt-bitmask-char #\( 2.-doppelquote-backslash-readtable )
917
(sys::rt-bitmask-char #\) 2.-doppelquote-backslash-readtable )
917
(set-syntax-from-char #\( #\) 2.-doppelquote-backslash-readtable )
T
(sys::rt-bitmask-char #\" 2.-doppelquote-backslash-readtable )
117
(sys::rt-bitmask-char #\\ 2.-doppelquote-backslash-readtable )
2306
(sys::rt-bitmask-char #\( 2.-doppelquote-backslash-readtable )
165
(sys::rt-bitmask-char #\) 2.-doppelquote-backslash-readtable )
917
(set-syntax-from-char #\( #\( 2.-doppelquote-liston-readtable
2.-doppelquote-backslash-readtable )
T
(sys::rt-bitmask-char #\" 2.-doppelquote-liston-readtable )
917
(sys::rt-bitmask-char #\( 2.-doppelquote-liston-readtable )
165
(sys::rt-bitmask-char #\) 2.-doppelquote-liston-readtable )
165
(sys::rt-bitmask-char #\\ 2.-doppelquote-liston-readtable )
2306
(set-syntax-from-char #\) #\) 2.-doppelquote-liston-readtable
2.-doppelquote-backslash-readtable )
T
(sys::rt-bitmask-char #\" 2.-doppelquote-liston-readtable )
917
(sys::rt-bitmask-char #\( 2.-doppelquote-liston-readtable )
165
(sys::rt-bitmask-char #\) 2.-doppelquote-liston-readtable )
917
(sys::rt-bitmask-char #\\ 2.-doppelquote-liston-readtable )
2306
(progn (setq *readtable* 2.-doppelquote-backslash-readtable ) t)
t
)sys::rt-bitmask-char #\( (
165
)sys::rt-bitmask-char #\) (
917
)sys::rt-bitmask-char #\\ (
2306
"1234"
"1234"
')1 2 3(
(1 2 3)
)progn )setq *readtable* 2.-doppelquote-liston-readtable ( t(
t
)sys::rt-bitmask-char #\( (
165
)sys::rt-bitmask-char #\) (
917
)sys::rt-bitmask-char #\\ (
2306
'"1234(
(1234)
')1 2 3(
(1 2 3)
;; ) muesste listen-anfang-sein
)progn )setq *readtable* )copy-readtable nil(( t(
t
(sys::rt-bitmask-char #\" )
117
(sys::rt-bitmask-char #\( )
917
(sys::rt-bitmask-char #\) )
165
(sys::rt-bitmask-char #\\ )
2306
(sys::rt-bitmask-char #\x )
4097
(sys::rt-bitmask-char #\y )
1
(make-dispatch-macro-character #\x)
T
(sys::rt-bitmask-char #\x )
4109
(sys::rt-bitmask-char #\y )
1
(defun d1 (a b c) (princ "1.dmacro"))
D1
(d1 1 2 3)
"1.dmacro"
(set-dispatch-macro-character #\x #\. #'d1)
T
(sys::rt-bitmask-char #\x )
4109
(prin1-to-string (get-dispatch-macro-character #\x #\.))
"#<SYSTEM::%TYPE-CLOSURE D1
NIL
NIL
(LAMBDA (A B C) (PRINC \"1.dmacro\"))>"
(multiple-value-list (read-from-string "123x.45"))
( 123 3)
(multiple-value-list (read-from-string "123x.45" t nil :start 3))
( "1.dmacro" 5)
(multiple-value-list (read-from-string "123x.45" t nil :start 5))
(45 7)
(make-dispatch-macro-character #\y)
T
(s\Ys::rt-bitmask-char #\x )
4109
(s\Ys::rt-bitmask-char #\y )
13
(defun d2 (a b c) (princ "2.dmacro"))
D2
(d2 1 2 3)
"2.dmacro"
(set-dispatch-macro-character #\y #\, #'d2)
T
(s\Ys::rt-bitmask-char #\x )
4109
(s\Ys::rt-bitmask-char #\y )
13
(prin1-to-string (get-dispatch-macro-character #\x #\.))
"#<SYSTEM::%TYPE-CLOSURE D1
NIL
NIL
(LAMBDA (A B C) (PRINC \"1.dmacro\"))>"
(prin1-to-string (get-dispatch-macro-character #\y #\,))
"#<SYSTEM::%TYPE-CLOSURE D2
NIL
NIL
(LAMBDA (A B C) (PRINC \"2.dmacro\"))>"
(multiple-value-list (read-from-string "123y,45"))
( 123 3)
(multiple-value-list (read-from-string "123y,45" t nil :start 3))
( "2.dmacro" 5)
(multiple-value-list (read-from-string "123y,45" t nil :start 5))
(45 7)
(set-dispatch-macro-character #\x #\. #'d2)
T
(s\Ys::rt-bitmask-char #\x )
4109
(s\Ys::rt-bitmask-char #\y )
13
(prin1-to-string (get-dispatch-macro-character #\y #\,))
"#<SYSTEM::%TYPE-CLOSURE D2
NIL
NIL
(LAMBDA (A B C) (PRINC \"2.dmacro\"))>"
(prin1-to-string (get-dispatch-macro-character #\x #\.))
"#<SYSTEM::%TYPE-CLOSURE D2
NIL
NIL
(LAMBDA (A B C) (PRINC \"2.dmacro\"))>"
(multiple-value-list (read-from-string "123x.45"))
( 123 3)
(multiple-value-list (read-from-string "123x.45" t nil :start 3))
( "2.dmacro" 5)
(multiple-value-list (read-from-string "123x.45" t nil :start 5))
(45 7)
(set-dispatch-macro-character #\y #\. #'d1)
T
(s\Ys::rt-bitmask-char #\x )
4109
(s\Ys::rt-bitmask-char #\y )
13
(prin1-to-string (get-dispatch-macro-character #\x #\.))
"#<SYSTEM::%TYPE-CLOSURE D2
NIL
NIL
(LAMBDA (A B C) (PRINC \"2.dmacro\"))>"
(prin1-to-string (get-dispatch-macro-character #\y #\,))
"#<SYSTEM::%TYPE-CLOSURE D2
NIL
NIL
(LAMBDA (A B C) (PRINC \"2.dmacro\"))>"
(prin1-to-string (get-dispatch-macro-character #\y #\.))
"#<SYSTEM::%TYPE-CLOSURE D1
NIL
NIL
(LAMBDA (A B C) (PRINC \"1.dmacro\"))>"
(multiple-value-list (read-from-string "123y.45"))
( 123 3)
(multiple-value-list (read-from-string "123y.45" t nil :start 3))
( "1.dmacro" 5)
(multiple-value-list (read-from-string "123y.45" t nil :start 5))
(45 7)
(multiple-value-list (read-from-string "123y,45"))
( 123 3)
(multiple-value-list (read-from-string "123y,45" t nil :start 3))
( "2.dmacro" 5)
(multiple-value-list (read-from-string "123y,45" t nil :start 5))
(45 7)
(progn (setq *readtable* (cop\Y-readtable nil nil)) t)
t
(sys::rt-bitmask-char #\x )
4097
(sys::rt-bitmask-char #\y )
1
(get-dispatch-macro-character #\x #\.)
ERROR
(get-dispatch-macro-character #\y #\,)
ERROR
(get-dispatch-macro-character #\y #\.)
ERROR
(defun |#{-reader| (stream char arg)
(declare (ignore char arg))
(mapcon #'(lambda (x)
(mapcar #'(lambda (y)(list (car x) y))(cdr x)))
(read-delimited-list #\} stream)))
|#{|-|reader|
(set-dispatch-macro-character #\# #\{ #'|#{-reader|)
T
;; (set-macro-character #\} (get-macro-character #\)) nil))
;; geht bei uns nicht !
;; dafuer :
(set-syntax-from-char #\} #\) )
;; nicht notwendig, da superklammer
(progn
(setq read-st (make-string-input-stream "#{p q z a} #{a b c d}")) t)
T
(read read-st)
((P Q) (P Z) (P A) (Q Z) (Q A) (Z A))
(read read-st)
((A B) (A C) (A D) (B C) (B D) (C D))
(progn (setq *readtable* (copy-readtable nil nil))
(makunbound 'doppelquote-liston-readtable)
(makunbound 'doppelquote-backslash-readtable)
(makunbound '2.-doppelquote-liston-readtable)
(makunbound '2.-doppelquote-backslash-readtable)
(makunbound 'cl-standard-readtable)
(makunbound 'read-st)
(makunbound '$)
t)
T

960
src/ansi-tests/section10.lisp Normal file
View file

@ -0,0 +1,960 @@
;;; section 10: symbols -*- mode: lisp -*-
(in-package :cl-user)
;;; symbolp
(my-assert
(symbolp 'elephant)
t)
(my-assert
(symbolp 12)
nil)
(my-assert
(symbolp nil)
t)
(my-assert
(symbolp '())
t)
(my-assert
(symbolp :test)
t)
(my-assert
(symbolp "hello")
nil)
;;; keywordp
(my-assert
(keywordp 'elephant)
nil)
(my-assert
(keywordp 12)
nil)
(my-assert
(keywordp :test)
t)
(my-assert
(keywordp ':test)
t)
(my-assert
(keywordp nil)
nil)
(my-assert
(keywordp :nil)
t)
(my-assert
(keywordp '(:test))
nil)
(my-assert
(keywordp "hello")
nil)
(my-assert
(keywordp ":hello")
nil)
(my-assert
(keywordp '&optional)
nil)
;;; make-symbol
(my-assert
(setq temp-string "temp")
"temp")
(my-assert
(progn
(setq temp-symbol (make-symbol temp-string))
t)
t)
(my-assert
(symbol-name temp-symbol)
"temp")
(my-assert
(eq (symbol-name temp-symbol) temp-string)
#+(or cmu sbcl clisp ecls) t
#-(or cmu sbcl clisp ecls) fill-this-in)
(my-assert
(multiple-value-bind (a b)
(find-symbol "temp")
(list a b))
( NIL NIL))
(my-assert
(eq (make-symbol temp-string) (make-symbol temp-string))
nil)
;;; copy-symbol
(my-assert
(setq fred 'fred-smith)
FRED-SMITH)
(my-assert
(setf (symbol-value fred) 3)
3)
(my-assert
(progn
(setq fred-clone-1a (copy-symbol fred nil))
t)
t)
(my-assert
(progn
(setq fred-clone-1b (copy-symbol fred nil))
t)
t)
(my-assert
(progn
(setq fred-clone-2a (copy-symbol fred t))
t)
t)
(my-assert
(progn
(setq fred-clone-2b (copy-symbol fred t))
t)
t)
(my-assert
(eq fred fred-clone-1a)
nil)
(my-assert
(eq fred-clone-1a fred-clone-1b)
nil)
(my-assert
(eq fred-clone-2a fred-clone-2b)
nil)
(my-assert
(eq fred-clone-1a fred-clone-2a)
nil)
(my-assert
(symbol-value fred)
3)
(my-assert
(boundp fred-clone-1a)
nil)
(my-assert
(symbol-value fred-clone-2a)
3)
(my-assert
(setf (symbol-value fred-clone-2a) 4)
4)
(my-assert
(symbol-value fred)
3)
(my-assert
(symbol-value fred-clone-2a)
4)
(my-assert
(symbol-value fred-clone-2b)
3)
(my-assert
(boundp fred-clone-1a)
nil)
(my-assert
(progn
(setf (symbol-function fred) #'(lambda (x) x))
t)
t)
(my-assert
(fboundp fred)
t)
(my-assert
(fboundp fred-clone-1a)
nil)
(my-assert
(fboundp fred-clone-2a)
nil)
;;; symbol-function
(my-assert
(progn
(symbol-function 'car)
t)
t)
(my-assert
(symbol-function 'twice)
UNDEFINED-FUNCTION)
(my-assert
(defun twice (n) (* n 2))
TWICE)
(my-assert
(progn
(symbol-function 'twice)
t)
t)
(my-assert
(list (twice 3)
(funcall (function twice) 3)
(funcall (symbol-function 'twice) 3))
(6 6 6))
(my-assert
(flet ((twice (x) (list x x)))
(list (twice 3)
(funcall (function twice) 3)
(funcall (symbol-function 'twice) 3)))
((3 3) (3 3) 6) )
(my-assert
(progn
(setf (symbol-function 'twice) #'(lambda (x) (list x x)))
t)
t)
(my-assert
(list (twice 3)
(funcall (function twice) 3)
(funcall (symbol-function 'twice) 3))
((3 3) (3 3) (3 3)))
(my-assert
(fboundp 'defun)
t)
(my-assert
(progn
(symbol-function 'defun)
t)
t)
(my-assert
(progn
(functionp (symbol-function 'defun))
t)
t)
(my-assert
(defun symbol-function-or-nil (symbol)
(if (and (fboundp symbol)
(not (macro-function symbol))
(not (special-operator-p symbol)))
(symbol-function symbol)
nil))
SYMBOL-FUNCTION-OR-NIL)
(my-assert
(progn
(symbol-function-or-nil 'car)
t)
t)
(my-assert
(symbol-function-or-nil 'defun)
NIL)
;;; symbol-name
(my-assert
(symbol-name 'temp)
"TEMP" )
(my-assert
(symbol-name :start)
"START")
;;; symbol-package
(my-assert
(progn
(in-package "CL-USER")
t)
t)
(my-assert
(progn
(symbol-package 'car)
t)
t)
(my-assert
(progn
(symbol-package 'bus)
t)
t)
(my-assert
(progn
(symbol-package :optional)
t)
t)
;; Gensyms are uninterned, so have no home package.
(my-assert
(symbol-package (gensym))
NIL)
(if (find-package "PK2")
(delete-package
(find-package "PK2")))
(if (find-package "PK1")
(delete-package
(find-package "PK1")))
(my-assert
(find-package "PK1")
nil)
(my-assert
(progn
(make-package 'pk1)
t)
t)
(my-assert
(multiple-value-bind (a b)
(intern "SAMPLE1" "PK1")
(list a b))
(PK1::SAMPLE1 :internal))
(my-assert
(export (find-symbol "SAMPLE1" "PK1") "PK1")
T)
(my-assert
(progn
(make-package 'pk2 :use '(pk1))
t)
t)
(my-assert
(multiple-value-bind (a b)
(find-symbol "SAMPLE1" "PK2")
(list a b))
(PK1:SAMPLE1 :INHERITED))
(my-assert
(progn
(symbol-package 'pk1::sample1)
t)
t)
(my-assert
(progn
(symbol-package 'pk2::sample1)
t)
t)
(my-assert
(progn
(symbol-package 'pk1::sample2)
t)
t)
(my-assert
(progn
(symbol-package 'pk2::sample2)
t)
t)
;; The next several forms create a scenario in which a symbol
;; is not really uninterned, but is "apparently uninterned",
;; and so SYMBOL-PACKAGE still returns NIL.
(my-assert
(setq s3 'pk1::sample3)
PK1::SAMPLE3)
(my-assert
(import s3 'pk2)
T)
(my-assert
(unintern s3 'pk1)
T)
(my-assert
(symbol-package s3)
NIL)
(my-assert
(eq s3 'pk2::sample3)
T)
;;; symbol-plist
(setq sym (gensym))
(my-assert
(symbol-plist sym)
())
(my-assert
(setf (get sym 'prop1) 'val1)
VAL1)
(my-assert
(symbol-plist sym)
(PROP1 VAL1))
(my-assert
(setf (get sym 'prop2) 'val2)
VAL2)
(my-assert
(symbol-plist sym)
(PROP2 VAL2 PROP1 VAL1))
(my-assert
(setf (symbol-plist sym) (list 'prop3 'val3))
(PROP3 VAL3))
(my-assert
(symbol-plist sym)
(PROP3 VAL3))
;;; setf
(my-assert
(setf (symbol-value 'a) 1)
1)
(my-assert
(symbol-value 'a)
1)
;; SYMBOL-VALUE can see dynamic variables.
(my-assert
(let ((a 2))
(declare (special a))
(symbol-value 'a))
2)
(my-assert
(let ((a 2))
(declare (special a))
(setq a 3)
(symbol-value 'a))
3)
(my-assert
(let ((a 2))
(setf (symbol-value 'a) 3)
t)
t)
;(my-assert
;a
;3)
;(my-assert
;(symbol-value 'a)
;3)
(my-assert
(multiple-value-bind (h j)
(let ((a 4))
(declare (special a))
(let ((b (symbol-value 'a)))
(setf (symbol-value 'a) 5)
(values a b)))
(list h j))
(5 4))
;(my-assert
;a
;3)
(my-assert
(symbol-value :any-keyword)
:ANY-KEYWORD)
(my-assert
(symbol-value 'nil)
NIL)
(my-assert
(symbol-value '())
NIL)
;; The precision of this next one is implementation-dependent.
(my-assert
(symbol-value 'pi)
#-clisp
3.141592653589793d0
#+clisp
3.1415926535897932385L0)
;;; get
(my-assert
(defun make-person (first-name last-name)
(let ((person (gensym "PERSON")))
(setf (get person 'first-name) first-name)
(setf (get person 'last-name) last-name)
person))
MAKE-PERSON)
(my-assert
(defvar *john* (make-person "John" "Dow"))
*JOHN*)
(my-assert
(progn
*john*
t)
t)
(my-assert
(defvar *sally* (make-person "Sally" "Jones"))
*SALLY*)
(my-assert
(get *john* 'first-name)
"John")
(my-assert
(get *sally* 'last-name)
"Jones")
(my-assert
(defun marry (man woman married-name)
(setf (get man 'wife) woman)
(setf (get woman 'husband) man)
(setf (get man 'last-name) married-name)
(setf (get woman 'last-name) married-name)
married-name)
MARRY)
(my-assert
(marry *john* *sally* "Dow-Jones")
"Dow-Jones")
(my-assert
(get *john* 'last-name)
"Dow-Jones")
(my-assert
(get (get *john* 'wife) 'first-name)
"Sally")
(my-assert
(progn
(symbol-plist *john*)
t)
t)
(my-assert
(defmacro age (person &optional (default ''thirty-something))
`(get ,person 'age ,default))
AGE)
(my-assert
(age *john*)
THIRTY-SOMETHING)
(my-assert
(age *john* 20)
20)
(my-assert
(setf (age *john*) 25)
25)
(my-assert
(age *john*)
25)
(my-assert
(age *john* 20)
25)
;;; remprop
(my-assert
(progn
(setq test (make-symbol "PSEUDO-PI"))
t)
t)
(my-assert
(symbol-plist test)
())
(my-assert
(setf (get test 'constant) t)
T)
(my-assert
(setf (get test 'approximation) 3.14)
3.14)
(my-assert
(setf (get test 'error-range) 'noticeable)
NOTICEABLE)
(my-assert
(symbol-plist test)
(ERROR-RANGE NOTICEABLE APPROXIMATION 3.14 CONSTANT T))
(my-assert
(setf (get test 'approximation) nil)
NIL)
(my-assert
(symbol-plist test)
(ERROR-RANGE NOTICEABLE APPROXIMATION NIL CONSTANT T))
(my-assert
(get test 'approximation)
NIL)
(my-assert
(not (remprop test 'approximation))
nil)
(my-assert
(get test 'approximation)
NIL)
(my-assert
(symbol-plist test)
(ERROR-RANGE NOTICEABLE CONSTANT T))
(my-assert
(remprop test 'approximation)
NIL)
(my-assert
(symbol-plist test)
(ERROR-RANGE NOTICEABLE CONSTANT T))
(my-assert
(not (remprop test 'error-range))
nil)
(my-assert
(setf (get test 'approximation) 3)
3)
(my-assert
(symbol-plist test)
(APPROXIMATION 3 CONSTANT T))
;;; boundp
(my-assert
(setq x 1)
1)
(my-assert
(boundp 'x)
t)
(my-assert
(makunbound 'x)
X)
(my-assert
(boundp 'x)
nil)
(my-assert
(let ((x 2)) (declare (special x)) (boundp 'x))
t)
;;; mkunbound
(my-assert
(setf (symbol-value 'a) 1)
1)
(my-assert
(boundp 'a)
t)
(my-assert
a
1)
(my-assert
(makunbound 'a)
A)
(my-assert
(boundp 'a)
nil)
;;; set
(my-assert
(setf (symbol-value 'n) 1)
1)
(my-assert
(set 'n 2)
2)
(my-assert
(symbol-value 'n)
2)
;(my-assert
;(let ((n 3))
; (declare (special n))
; (setq n (+ n 1))
; (setf (symbol-value 'n) (* n 10))
; (set 'n (+ (symbol-value 'n) n))
; n)
;80)
;(my-assert
;n
;2)
;(my-assert
;(let ((n 3))
; (setq n (+ n 1))
; (setf (symbol-value 'n) (* n 10))
; (set 'n (+ (symbol-value 'n) n))
; n)
;4)
;(my-assert
;n
;44)
(my-assert
(defvar *n* 2)
*N*)
(my-assert
(let ((*n* 3))
(setq *n* (+ *n* 1))
(setf (symbol-value '*n*) (* *n* 10))
(set '*n* (+ (symbol-value '*n*) *n*))
*n*)
80)
(my-assert
*n*
2)
(my-assert
(defvar *even-count* 0)
*EVEN-COUNT*)
(my-assert
(defvar *odd-count* 0)
*ODD-COUNT*)
(my-assert
(defun tally-list (list)
(dolist (element list)
(set (if (evenp element) '*even-count* '*odd-count*)
(+ element (if (evenp element) *even-count* *odd-count*)))))
tally-list)
(my-assert
(tally-list '(1 9 4 3 2 7))
NIL)
(my-assert
*even-count*
6)
(my-assert
*odd-count*
20)

5
src/ansi-tests/section11.lisp Normal file
View file

@ -0,0 +1,5 @@
;;; section 11: packages -*- mode: lisp -*-
(in-package :cl-user)
;;; bah

861
src/ansi-tests/section12.lisp Normal file
View file

@ -0,0 +1,861 @@
;;; 12: numbers -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
;;; 12.1.4.1.1
;;;; Combining rationals with floats.
;;; This example assumes an implementation in which
;;; (float-radix 0.5) is 2 (as in IEEE) or 16 (as in IBM/360),
;;; or else some other implementation in which 1/2 has an exact
;;; representation in floating point.
(my-assert
(+ 1/2 0.5)
1.0)
(my-assert
(- 1/2 0.5d0)
0.0d0)
(my-assert
(+ 0.5 -0.5 1/2)
0.5)
;;;; Comparing rationals with floats.
;;; This example assumes an implementation in which the default float
;;; format is IEEE single-float, IEEE double-float, or some other format
;;; in which 5/7 is rounded upwards by FLOAT.
(my-assert
(< 5/7 (float 5/7))
t)
(my-assert
(< 5/7 (rational (float 5/7)))
t)
(my-assert
(< (float 5/7) (float 5/7))
nil)
;;; 12.1.5.3.1
(my-assert
#c(1.0 1.0)
#C(1.0 1.0))
(my-assert
#c(0.0 0.0)
#C(0.0 0.0))
(my-assert
#c(1.0 1)
#C(1.0 1.0))
(my-assert
#c(0.0 0)
#C(0.0 0.0))
(my-assert
#c(1 1)
#C(1 1))
(my-assert
#c(0 0)
0)
(my-assert
(typep #c(1 1) '(complex (eql 1)))
t)
(my-assert
(typep #c(0 0) '(complex (eql 0)))
nil)
;;; number
(my-assert
(subtypep 'real 'number)
t)
(my-assert
(subtypep 'complex 'number)
t)
(my-assert
(subtypep 'rational 'real)
t)
(my-assert
(subtypep 'float 'real)
t)
;;; float
(my-assert
(subtypep 'short-float 'float)
t)
(my-assert
(subtypep 'single-float 'float)
t)
(my-assert
(subtypep 'double-float 'float)
t)
(my-assert
(subtypep 'long-float 'float)
t)
;;; rational
(my-assert
(subtypep 'integer 'rational)
t)
(my-assert
(subtypep 'ratio 'rational)
t)
;;; integer
(my-assert
(subtypep 'fixnum 'integer)
t)
(my-assert
(subtypep 'bignum 'integer)
t)
;;; fixnum
(my-assert
(subtypep '(signed-byte 16) 'fixnum)
t)
;;; = /= < > <= >=
(my-assert
(= 3 3)
t)
(my-assert
(/= 3 3)
nil)
(my-assert
(= 3 5)
nil)
(my-assert
(/= 3 5)
t)
(my-assert
(= 3 3 3 3)
t)
(my-assert
(/= 3 3 3 3)
nil)
(my-assert
(= 3 3 5 3)
nil)
(my-assert
(/= 3 3 5 3)
nil)
(my-assert
(= 3 6 5 2)
nil)
(my-assert
(/= 3 6 5 2)
t)
(my-assert
(= 3 2 3)
nil)
(my-assert
(/= 3 2 3)
nil)
(my-assert
(< 3 5)
t)
(my-assert
(<= 3 5)
t)
(my-assert
(< 3 -5)
nil)
(my-assert
(<= 3 -5)
nil)
(my-assert
(< 3 3)
nil)
(my-assert
(<= 3 3)
t)
(my-assert
(< 0 3 4 6 7)
t)
(my-assert
(<= 0 3 4 6 7)
t)
(my-assert
(< 0 3 4 4 6)
nil)
(my-assert
(<= 0 3 4 4 6)
t)
(my-assert
(> 4 3)
t)
(my-assert
(>= 4 3)
t)
(my-assert
(> 4 3 2 1 0)
t)
(my-assert
(>= 4 3 2 1 0)
t)
(my-assert
(> 4 3 3 2 0)
nil)
(my-assert
(>= 4 3 3 2 0)
t)
(my-assert
(> 4 3 1 2 0)
nil)
(my-assert
(>= 4 3 1 2 0)
nil)
(my-assert
(= 3)
t)
(my-assert
(/= 3)
t)
(my-assert
(< 3)
t)
(my-assert
(<= 3)
t)
(my-assert
(= 3.0 #c(3.0 0.0))
t)
(my-assert
(/= 3.0 #c(3.0 1.0))
t)
(my-assert
(= 3 3.0)
t)
(my-assert
(= 3.0s0 3.0d0)
t)
(my-assert
(= 0.0 -0.0)
t)
(my-assert
(= 5/2 2.5)
t)
(my-assert
(> 0.0 -0.0)
nil)
(my-assert
(= 0 -0.0)
t)
;;; min max
(my-assert
(max 3)
3 )
(my-assert
(min 3)
3)
(my-assert
(max 6 12)
12 )
(my-assert
(min 6 12)
6)
(my-assert
(max -6 -12)
-6 )
(my-assert
(min -6 -12)
-12)
(my-assert
(max 1 3 2 -7)
3 )
(my-assert
(min 1 3 2 -7)
-7)
(my-assert
(max -2 3 0 7)
7 )
(my-assert
(min -2 3 0 7)
-2)
(my-assert
(max 5.0 2)
5.0 )
(my-assert
(min 5.0 2)
#+(or cmu sbcl clisp ecls) 2
#-(or cmu sbcl clisp ecls) fill-this-in)
; 2 OR 2.0
(my-assert
(max 3.0 7 1)
#+(or cmu sbcl clisp ecls) 7
#-(or cmu sbcl clisp ecls) fill-this-in)
; 7 OR 7.0
(my-assert
(min 3.0 7 1)
#+(or cmu sbcl clisp ecls) 1
#-(or cmu sbcl clisp ecls) fill-this-in)
; 1 OR 1.0
(my-assert
(max 1.0s0 7.0d0)
7.0d0)
(my-assert
(min 1.0s0 7.0d0)
#+(or cmu sbcl ecls) 1.0 ;hmm in fact an error?
#+clisp 1.0s0
#-(or cmu sbcl clisp ecls) fill-this-in)
; 1.0s0 OR 1.0d0
(my-assert
(max 3 1 1.0s0 1.0d0)
#+(or cmu sbcl clisp ecls) 3
#-(or cmu sbcl clisp ecls) fill-this-in)
; 3 OR 3.0d0
(my-assert
(min 3 1 1.0s0 1.0d0)
#+(or cmu sbcl clisp ecls) 1
#-(or cmu sbcl clisp ecls) fill-this-in)
; 1 OR 1.0s0 OR 1.0d0
;;; plusp minusp
(my-assert
(minusp -1)
t)
(my-assert
(plusp 0)
nil)
(my-assert
(plusp least-positive-single-float)
t)
(my-assert
(plusp least-positive-double-float)
t)
(my-assert
(minusp least-positive-single-float)
nil)
(my-assert
(minusp least-positive-double-float)
nil)
(my-assert
(plusp least-negative-single-float)
nil)
(my-assert
(plusp least-negative-double-float)
nil)
(my-assert
(minusp least-negative-single-float)
t)
(my-assert
(minusp least-negative-double-float)
t)
(my-assert
(minusp 0)
nil)
(my-assert
(minusp -0.0)
nil)
(my-assert
(minusp +0.0)
nil)
(my-assert
(plusp 0)
nil)
(my-assert
(plusp -0.0)
nil)
(my-assert
(plusp +0.0)
nil)
;;; zerop
(my-assert
(zerop 0)
t)
(my-assert
(zerop 0.0)
t)
(my-assert
(zerop +0.0)
t)
(my-assert
(zerop -0.0)
t)
(my-assert
(zerop -1)
nil)
(my-assert
(zerop 1)
nil)
(my-assert
(zerop 0/100)
t)
(my-assert
(zerop #c(0 0.0))
t)
;;; random-state-p
(my-assert
(random-state-p *random-state*)
t)
(my-assert
(random-state-p (make-random-state))
t)
(my-assert
(random-state-p 'test-function)
nil)
;;; number-p
(my-assert
(numberp 12)
t)
(my-assert
(numberp (expt 2 130))
t)
(my-assert
(numberp #c(5/3 7.2))
t)
(my-assert
(numberp nil)
nil)
(my-assert
(numberp (cons 1 2))
nil)
;;; most-positive-fixnum
(my-assert
(>= most-positive-fixnum (- (expt 2 15) 1))
t)
(my-assert
(>= most-positive-fixnum array-dimension-limit)
t
"
most-positive-fixnum is that fixnum closest in value
to positive infinity provided by the implementation, and
greater than or equal to both 2^15 - 1 and array-dimension-limit.
")
(my-assert
(<= most-negative-fixnum (- (expt 2 15)))
t)
;;; most-positive bla bla
(my-assert
(plusp MOST-POSITIVE-SHORT-FLOAT)
t)
(my-assert
(plusp LEAST-POSITIVE-SHORT-FLOAT)
t)
(my-assert
(plusp LEAST-POSITIVE-NORMALIZED-SHORT-FLOAT)
t)
(my-assert
(plusp MOST-POSITIVE-DOUBLE-FLOAT)
t)
(my-assert
(plusp LEAST-POSITIVE-DOUBLE-FLOAT)
t)
(my-assert
(plusp LEAST-POSITIVE-NORMALIZED-DOUBLE-FLOAT)
t)
(my-assert
(plusp MOST-POSITIVE-LONG-FLOAT)
t)
(my-assert
(plusp LEAST-POSITIVE-LONG-FLOAT)
t)
(my-assert
(plusp LEAST-POSITIVE-NORMALIZED-LONG-FLOAT)
t)
(my-assert
(plusp MOST-POSITIVE-SINGLE-FLOAT)
t)
(my-assert
(plusp LEAST-POSITIVE-SINGLE-FLOAT)
t)
(my-assert
(plusp LEAST-POSITIVE-NORMALIZED-SINGLE-FLOAT)
t)
(my-assert
(minusp MOST-NEGATIVE-SHORT-FLOAT)
t)
(my-assert
(minusp LEAST-NEGATIVE-SHORT-FLOAT)
t)
(my-assert
(minusp LEAST-NEGATIVE-NORMALIZED-SHORT-FLOAT)
t)
(my-assert
(minusp MOST-NEGATIVE-SINGLE-FLOAT)
t)
(my-assert
(minusp LEAST-NEGATIVE-SINGLE-FLOAT)
t)
(my-assert
(minusp LEAST-NEGATIVE-NORMALIZED-SINGLE-FLOAT)
t)
(my-assert
(minusp MOST-NEGATIVE-DOUBLE-FLOAT)
t)
(my-assert
(minusp LEAST-NEGATIVE-DOUBLE-FLOAT)
t)
(my-assert
(minusp LEAST-NEGATIVE-NORMALIZED-DOUBLE-FLOAT)
t)
(my-assert
(minusp MOST-NEGATIVE-LONG-FLOAT)
t)
(my-assert
(minusp LEAST-NEGATIVE-LONG-FLOAT)
t)
(my-assert
(minusp LEAST-NEGATIVE-NORMALIZED-LONG-FLOAT)
t)
;;; epsilons
(my-assert
(not (= (float 1 short-float-epsilon)
(+ (float 1 short-float-epsilon) short-float-epsilon)))
t
"The value of each of the constants short-float-epsilon,
single-float-epsilon, double-float-epsilon, and
long-float-epsilon is the smallest positive float
<EPSILON> of the given format, such that the following
expression is true when evaluated:
(not (= (float 1 <EPSILON>) (+ (float 1 <EPSILON>) <EPSILON>))
")
(my-assert
(not (= (float 1 single-float-epsilon)
(+ (float 1 single-float-epsilon) single-float-epsilon)))
t
"The value of each of the constants short-float-epsilon,
single-float-epsilon, double-float-epsilon, and
long-float-epsilon is the smallest positive float
<EPSILON> of the given format, such that the following
expression is true when evaluated:
(not (= (float 1 <EPSILON>) (+ (float 1 <EPSILON>) <EPSILON>))
")
(my-assert
(not (= (float 1 double-float-epsilon)
(+ (float 1 double-float-epsilon) double-float-epsilon)))
t
"The value of each of the constants short-float-epsilon,
single-float-epsilon, double-float-epsilon, and
long-float-epsilon is the smallest positive float
<EPSILON> of the given format, such that the following
expression is true when evaluated:
(not (= (float 1 <EPSILON>) (+ (float 1 <EPSILON>) <EPSILON>))
")
(my-assert
(not (= (float 1 long-float-epsilon )
(+ (float 1 long-float-epsilon ) long-float-epsilon )))
t
"The value of each of the constants short-float-epsilon,
single-float-epsilon, double-float-epsilon, and
long-float-epsilon is the smallest positive float
<EPSILON> of the given format, such that the following
expression is true when evaluated:
(not (= (float 1 <EPSILON>) (+ (float 1 <EPSILON>) <EPSILON>))
")
(my-assert
(not (= (float 1 short-float-negative-epsilon)
(- (float 1 short-float-negative-epsilon)
short-float-negative-epsilon)))
t
"The value of each of the constants short-float-negative-epsilon,
single-float-negative-epsilon,
double-float-negative-epsilon, and long-float-negative-epsilon
is the smallest positive float <EPSILON> of
the given format, such that the following expression
is true when evaluated:
(not (= (float 1 <EPSILON>) (- (float 1 <EPSILON>) <EPSILON>))) ")
(my-assert
(not (= (float 1 single-float-negative-epsilon)
(- (float 1 single-float-negative-epsilon)
single-float-negative-epsilon)))
t
"The value of each of the constants short-float-negative-epsilon,
single-float-negative-epsilon,
double-float-negative-epsilon, and long-float-negative-epsilon
is the smallest positive float <EPSILON> of
the given format, such that the following expression
is true when evaluated:
(not (= (float 1 <EPSILON>) (- (float 1 <EPSILON>) <EPSILON>))) ")
(my-assert
(not (= (float 1 double-float-negative-epsilon)
(- (float 1 double-float-negative-epsilon)
double-float-negative-epsilon)))
t
"The value of each of the constants short-float-negative-epsilon,
single-float-negative-epsilon,
double-float-negative-epsilon, and long-float-negative-epsilon
is the smallest positive float <EPSILON> of
the given format, such that the following expression
is true when evaluated:
(not (= (float 1 <EPSILON>) (- (float 1 <EPSILON>) <EPSILON>))) ")
(my-assert
(not (= (float 1 long-float-negative-epsilon)
(- (float 1 long-float-negative-epsilon)
long-float-negative-epsilon)))
t
"The value of each of the constants short-float-negative-epsilon,
single-float-negative-epsilon,
double-float-negative-epsilon, and long-float-negative-epsilon
is the smallest positive float <EPSILON> of
the given format, such that the following expression
is true when evaluated:
(not (= (float 1 <EPSILON>) (- (float 1 <EPSILON>) <EPSILON>))) ")

583
src/ansi-tests/section13.lisp Normal file
View file

@ -0,0 +1,583 @@
;;; 13 characters -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
(my-assert
(subtypep 'base-char 'character)
T)
(my-assert
(subtypep 'standard-char 'base-char)
t)
(my-assert
(subtypep 'extended-char 'character)
t
"Type EXTENDED-CHAR
Supertypes:
extended-char, character, t")
;;; char= etc
(my-assert
(char= #\d #\d)
t)
(my-assert
(char= #\A #\a)
nil)
(my-assert
(char= #\d #\x)
nil)
(my-assert
(char= #\d #\D)
nil)
(my-assert
(char/= #\d #\d)
nil)
(my-assert
(char/= #\d #\x)
t)
(my-assert
(char/= #\d #\D)
t)
(my-assert
(char= #\d #\d #\d #\d)
t)
(my-assert
(char/= #\d #\d #\d #\d)
nil)
(my-assert
(char= #\d #\d #\x #\d)
nil)
(my-assert
(char/= #\d #\d #\x #\d)
nil)
(my-assert
(char= #\d #\y #\x #\c)
nil)
(my-assert
(char/= #\d #\y #\x #\c)
t)
(my-assert
(char= #\d #\c #\d)
nil)
(my-assert
(char/= #\d #\c #\d)
nil)
(my-assert
(char< #\d #\x)
t)
(my-assert
(char<= #\d #\x)
t)
(my-assert
(char< #\d #\d)
nil)
(my-assert
(char<= #\d #\d)
t)
(my-assert
(char< #\a #\e #\y #\z)
t)
(my-assert
(char<= #\a #\e #\y #\z)
t)
(my-assert
(char< #\a #\e #\e #\y)
nil)
(my-assert
(char<= #\a #\e #\e #\y)
t)
(my-assert
(char> #\e #\d)
t)
(my-assert
(char>= #\e #\d)
t)
(my-assert
(char> #\d #\c #\b #\a)
t)
(my-assert
(char>= #\d #\c #\b #\a)
t)
(my-assert
(char> #\d #\d #\c #\a)
nil)
(my-assert
(char>= #\d #\d #\c #\a)
t)
(my-assert
(char> #\e #\d #\b #\c #\a)
nil)
(my-assert
(char>= #\e #\d #\b #\c #\a)
nil)
(my-assert
(char> #\z #\A)
#+(or cmu sbcl clisp ecls) T
#-(or cmu sbcl clisp ecls) fill-this-in)
(my-assert
(char> #\Z #\a)
#+(or cmu sbcl clisp ecls) nil
#-(or cmu sbcl clisp ecls) fill-this-in)
(my-assert
(char-equal #\A #\a)
t)
(my-assert
(stable-sort (list #\b #\A #\B #\a #\c #\C) #'char-lessp)
(#\A #\a #\b #\B #\c #\C))
(my-assert
(stable-sort (list #\b #\A #\B #\a #\c #\C) #'char<)
#+(or cmu sbcl clisp ecls) (#\A #\B #\C #\a #\b #\c)
#-(or cmu sbcl clisp ecls) fill-this-in)
; (#\A #\B #\C #\a #\b #\c) ;Implementation A
; (#\a #\b #\c #\A #\B #\C) ;Implementation B
; (#\a #\A #\b #\B #\c #\C) ;Implementation C
; (#\A #\a #\B #\b #\C #\c) ;Implementation D
; (#\A #\B #\a #\b #\C #\c) ;Implementation E
;;; character
(my-assert
(character #\a)
#\a)
(my-assert
(character "a")
#\a)
(my-assert
(character 'a)
#\A)
(my-assert
(character '\a)
#\a)
(my-assert
(character 65.0)
TYPE-ERROR)
(my-assert
(character 'apple)
TYPE-ERROR)
;;; alpha-char-p
(my-assert
(alpha-char-p #\a)
t)
(my-assert
(alpha-char-p #\5)
nil)
(my-assert
(alpha-char-p #\Newline)
nil)
;;; alphanumericp
(my-assert
(alphanumericp #\Z)
t)
(my-assert
(alphanumericp #\9)
t)
(my-assert
(alphanumericp #\Newline)
nil)
(my-assert
(alphanumericp #\#)
nil)
;;; digit-char
(my-assert
(digit-char 0)
#\0)
(my-assert
(digit-char 10 11)
#\A)
(my-assert
(digit-char 10 10)
nil)
(my-assert
(digit-char 7)
#\7)
(my-assert
(digit-char 12)
nil)
(my-assert
(digit-char 12 16)
#\C)
(my-assert
(digit-char 6 2)
nil)
(my-assert
(digit-char 1 2)
#\1)
;;; digit-char-p
(my-assert
(digit-char-p #\5)
5)
(my-assert
(digit-char-p #\5 2)
nil)
(my-assert
(digit-char-p #\A)
nil)
(my-assert
(digit-char-p #\a)
nil)
(my-assert
(digit-char-p #\A 11)
10)
(my-assert
(digit-char-p #\a 11)
10)
(my-assert
(mapcar #'(lambda (radix)
(map 'list #'(lambda (x) (digit-char-p x radix))
"059AaFGZ"))
'(2 8 10 16 36))
((0 NIL NIL NIL NIL NIL NIL NIL)
(0 5 NIL NIL NIL NIL NIL NIL)
(0 5 9 NIL NIL NIL NIL NIL)
(0 5 9 10 10 15 NIL NIL)
(0 5 9 10 10 15 16 35)))
;;; graphic-char
(my-assert
(graphic-char-p #\G)
t)
(my-assert
(graphic-char-p #\#)
t)
(my-assert
(graphic-char-p #\Space)
t)
(my-assert
(graphic-char-p #\Newline)
nil)
;;; standard-char-p
(my-assert
(standard-char-p #\Space)
t)
(my-assert
(standard-char-p #\~)
t)
;;; char-upcase
(my-assert
(char-upcase #\a)
#\A)
(my-assert
(char-upcase #\A)
#\A)
(my-assert
(char-downcase #\a)
#\a)
(my-assert
(char-downcase #\A)
#\a)
(my-assert
(char-upcase #\9)
#\9)
(my-assert
(char-downcase #\9)
#\9)
(my-assert
(char-upcase #\@)
#\@)
(my-assert
(char-downcase #\@)
#\@)
;; Note that this next example might run for a very long time in
;; some implementations if CHAR-CODE-LIMIT happens to be very large
;; for that implementation.
(my-assert
(dotimes (code char-code-limit)
(let ((char (code-char code)))
(when char
(unless (cond ((upper-case-p char)
(char= (char-upcase
(char-downcase char)) char))
((lower-case-p char)
(char= (char-downcase
(char-upcase char)) char))
(t (and (char= (char-upcase
(char-downcase char)) char)
(char= (char-downcase
(char-upcase char)) char))))
(return char)))))
NIL)
;;; upper-case-p
(my-assert
(upper-case-p #\A)
t)
(my-assert
(upper-case-p #\a)
nil)
(my-assert
(both-case-p #\a)
t)
(my-assert
(both-case-p #\5)
nil)
(my-assert
(lower-case-p #\5)
nil)
(my-assert
(upper-case-p #\5)
nil)
;;; char-code-limit
(my-assert
(>= char-code-limit 96)
t)
;;; char-name
(my-assert
(char-name #\ )
"Space")
(my-assert
(char-name #\Space)
"Space")
(my-assert
(char-name #\Page)
"Page")
(my-assert
(char-name #\a)
#+(or cmu sbcl ecls) nil
#+clisp "LATIN_SMALL_LETTER_A"
#-(or cmu sbcl clisp ecls) fill-this-in)
;; NIL OR "LOWERCASE-a" OR "Small-A" OR "LA01"
(my-assert
(char-name #\A)
#+(or cmu sbcl ecls) nil
#+clisp "LATIN_CAPITAL_LETTER_A"
#-(or cmu sbcl clisp ecls) fill-this-in)
;; NIL OR "UPPERCASE-A" OR "Capital-A" OR "LA02"
;; Even though its CHAR-NAME can vary, #\A prints as #\A
(my-assert
(prin1-to-string (read-from-string (format nil "#\\~A" (or (char-name #\A) "A"))))
"#\\A")
;;; name-char
(my-assert
(name-char 'space)
#\Space)
(my-assert
(name-char "space")
#\Space)
(my-assert
(name-char "Space")
#\Space)
(my-assert
(let ((x (char-name #\a)))
(or (not x) (eql (name-char x) #\a)))
t)

1934
src/ansi-tests/section14.lisp Normal file
View file

File diff suppressed because it is too large Load diff

766
src/ansi-tests/section15.lisp Normal file
View file

@ -0,0 +1,766 @@
;;; section 15: arrays -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
(my-assert
(subtypep 'simple-array 'array)
t)
;;; make-array
(my-assert
(make-array 4 :initial-element nil)
#(NIL NIL NIL NIL))
(my-assert
(make-array '(2 4)
:element-type '(unsigned-byte 2)
:initial-contents '((0 1 2 3) (3 2 1 0)))
#2A((0 1 2 3) (3 2 1 0)))
(my-assert
(make-array 6
:element-type 'character
:initial-element #\a
:fill-pointer 3)
"aaa")
(my-assert
(progn
(setq a (make-array '(4 3)))
t)
t)
(my-assert
(dotimes (i 4)
(dotimes (j 3)
(setf (aref a i j) (list i 'x j '= (* i j)))))
NIL)
(my-assert
(progn
(setq b (make-array 8 :displaced-to a
:displaced-index-offset 2))
t)
t)
(my-assert
(let ((a '()))
(dotimes (i 8)
(setq a (append a (list i (aref b i)))))
a)
(0 (0 X 2 = 0)
1 (1 X 0 = 0)
2 (1 X 1 = 1)
3 (1 X 2 = 2)
4 (2 X 0 = 0)
5 (2 X 1 = 2)
6 (2 X 2 = 4)
7 (3 X 0 = 0)))
(my-assert
(progn
(setq a1 (make-array 50))
t)
t)
(my-assert
(progn
(setq b1 (make-array 20 :displaced-to a1 :displaced-index-offset 10))
t)
t)
(my-assert
(length b1)
20)
(my-assert
(progn
(setq a2 (make-array 50 :fill-pointer 10))
t)
t)
(my-assert
(progn
(setq b2 (make-array 20 :displaced-to a2 :displaced-index-offset 10))
t)
t)
(my-assert
(length a2)
10)
(my-assert
(length b2)
20)
(my-assert
(progn
(setq a3 (make-array 50 :fill-pointer 10))
t)
t)
(my-assert
(progn
(setq b3 (make-array 20 :displaced-to a3 :displaced-index-offset 10
:fill-pointer 5))
t)
t)
(my-assert
(length a3)
10)
(my-assert
(length b3)
5)
;;; adjust-array
(my-assert
(adjustable-array-p
(setq ada (adjust-array
(make-array '(2 3)
:adjustable t
:initial-contents '((a b c) (1 2 3)))
'(4 6))))
T )
(my-assert
(array-dimensions ada)
(4 6) )
(my-assert
(aref ada 1 1)
2 )
(my-assert
(setq beta (make-array '(2 3) :adjustable t))
#+(or cmu sbcl) #2A((0 0 0) (0 0 0))
#-(or cmu sbcl) #2A((NIL NIL NIL) (NIL NIL NIL)))
(my-assert
(adjust-array beta '(4 6) :displaced-to ada)
#+(or cmu sbcl) #2A((A B C 0 0 0)
(1 2 3 0 0 0)
(0 0 0 0 0 0)
(0 0 0 0 0 0))
#-(or cmu sbcl) #2A((A B C NIL NIL NIL)
(1 2 3 NIL NIL NIL)
(NIL NIL NIL NIL NIL NIL)
(NIL NIL NIL NIL NIL NIL)))
(my-assert
(array-dimensions beta)
(4 6))
(my-assert
(aref beta 1 1)
2 )
(my-assert
(let ((m
(make-array '(4 4)
:adjustable t
:initial-contents
'(( alpha beta gamma delta )
( epsilon zeta eta theta )
( iota kappa lambda mu )
( nu xi omicron pi )))))
m)
#2A(( alpha beta gamma delta )
( epsilon zeta eta theta )
( iota kappa lambda mu )
( nu xi omicron pi )))
(my-assert
(let ((m
(make-array '(4 4)
:adjustable t
:initial-contents
'(( alpha beta gamma delta )
( epsilon zeta eta theta )
( iota kappa lambda mu )
( nu xi omicron pi )))))
(adjust-array m '(3 5) :initial-element 'baz))
#2A(( alpha beta gamma delta baz )
( epsilon zeta eta theta baz )
( iota kappa lambda mu baz )))
;;; adjustable-array-p
(my-assert
(adjustable-array-p
(make-array 5
:element-type 'character
:adjustable t
:fill-pointer 3))
t)
;;; aref
(my-assert
(aref (setq alpha (make-array 4)) 3)
#+(or cmu sbcl) 0
#+(or clisp ecls) nil
#-(or cmu sbcl clisp ecls) fill-this-in)
(my-assert
(setf (aref alpha 3) 'sirens)
SIRENS)
(my-assert
(aref alpha 3)
SIRENS)
(my-assert
(aref (setq beta (make-array '(2 4)
:element-type '(unsigned-byte 2)
:initial-contents '((0 1 2 3) (3 2 1 0))))
1 2)
1)
(my-assert
(setq gamma '(0 2))
(0 2))
(my-assert
(apply #'aref beta gamma)
2)
(my-assert
(setf (apply #'aref beta gamma) 3)
3)
(my-assert
(apply #'aref beta gamma)
3)
(my-assert
(aref beta 0 2)
3)
;;; array-dimension
(my-assert
(array-dimension (make-array 4) 0)
4)
(my-assert
(array-dimension (make-array '(2 3)) 1)
3)
;;; array-dimensions
(my-assert
(array-dimensions (make-array 4))
(4))
(my-assert
(array-dimensions (make-array '(2 3)))
(2 3))
(my-assert
(array-dimensions (make-array 4 :fill-pointer 2))
(4))
;;; array-element-type
(my-assert
(array-element-type (make-array 4))
T)
(my-assert
(array-element-type (make-array 12 :element-type '(unsigned-byte 8)))
#+(or cmu sbcl clisp) (unsigned-byte 8)
#+ecls fixnum
#-(or cmu sbcl clisp ecls) fill-this-in)
(my-assert
(array-element-type (make-array 12 :element-type '(unsigned-byte 5)))
#+(or cmu sbcl clisp) (unsigned-byte 8)
#+ecls fixnum
#-(or cmu sbcl clisp ecls) fill-this-in)
(my-assert
(array-element-type (make-array 5 :element-type '(mod 5)))
#+(or cmu sbcl clisp) (UNSIGNED-BYTE 4)
#+ecls fixnum
#-(or cmu sbcl clisp ecls) fill-this-in)
; (mod 5), (mod 8), fixnum, t, or any other type of which (mod 5) is a subtype.
;;; array-has-fill-pointer
(my-assert
(array-has-fill-pointer-p (make-array 4))
#+(or cmu sbcl clisp ecls) nil
#-(or cmu sbcl clisp ecls) fill-this-in)
(my-assert
(array-has-fill-pointer-p (make-array '(2 3)))
nil)
(my-assert
(array-has-fill-pointer-p
(make-array 8
:fill-pointer 2
:initial-element 'filler))
t)
;;; array-displacement
(my-assert
(progn
(setq a1 (make-array 5))
t)
t)
(my-assert
(progn
(setq a2 (make-array 4 :displaced-to a1
:displaced-index-offset 1))
t)
t)
(my-assert
(progn
(multiple-value-bind (a b)
(array-displacement a2)
(list a b))
t)
t)
(my-assert
(progn
(setq a3 (make-array 2 :displaced-to a2
:displaced-index-offset 2))
t)
t)
(my-assert
(progn
(array-displacement a3)
t)
t)
;;; array-in-bounds
(my-assert
(progn
(setq a (make-array '(7 11) :element-type 'string-char))
t)
t)
(my-assert
(array-in-bounds-p a 0 0)
t)
(my-assert
(array-in-bounds-p a 6 10)
t)
(my-assert
(array-in-bounds-p a 0 -1)
nil)
(my-assert
(array-in-bounds-p a 0 11)
nil)
(my-assert
(array-in-bounds-p a 7 0)
nil)
;;; array-rank
(my-assert
(array-rank (make-array '()))
0)
(my-assert
(array-rank (make-array 4))
1)
(my-assert
(array-rank (make-array '(4)))
1)
(my-assert
(array-rank (make-array '(2 3)))
2)
;;; array-row-major-index
(my-assert
(progn
(setq a (make-array '(4 7) :element-type '(unsigned-byte 8)))
t)
t)
(my-assert
(array-row-major-index a 1 2)
9)
(my-assert
(array-row-major-index
(make-array '(2 3 4)
:element-type '(unsigned-byte 8)
:displaced-to a
:displaced-index-offset 4)
0 2 1)
9)
;;; array-total-size
(my-assert
(array-total-size (make-array 4))
4)
(my-assert
(array-total-size (make-array 4 :fill-pointer 2))
4)
(my-assert
(array-total-size (make-array 0))
0)
(my-assert
(array-total-size (make-array '(4 2)))
8)
(my-assert
(array-total-size (make-array '(4 0)))
0)
(my-assert
(array-total-size (make-array '()))
1)
;;; arrayp
(my-assert
(arrayp (make-array '(2 3 4) :adjustable t))
t)
(my-assert
(arrayp (make-array 6))
t)
(my-assert
(arrayp #*1011)
t)
(my-assert
(arrayp "hi")
t)
(my-assert
(arrayp 'hi)
nil)
(my-assert
(arrayp 12)
nil)
;;; fill-pointer
(my-assert
(setq a (make-array 8 :fill-pointer 4))
#+(or cmu sbcl) #(0 0 0 0)
#-(or cmu sbcl) #(NIL NIL NIL NIL))
(my-assert
(fill-pointer a)
4)
(my-assert
(dotimes (i (length a)) (setf (aref a i) (* i i)))
NIL)
(my-assert
a
#(0 1 4 9))
(my-assert
(setf (fill-pointer a) 3)
3)
(my-assert
(fill-pointer a)
3)
(my-assert
a
#(0 1 4))
(my-assert
(setf (fill-pointer a) 8)
8)
(my-assert
a
#+(or cmu sbcl) #(0 1 4 9 0 0 0 0)
#-(or cmu sbcl) #(0 1 4 9 NIL NIL NIL NIL))
(my-assert
(>= ARRAY-DIMENSION-LIMIT 1024)
t)
(my-assert
(>= ARRAY-RANK-LIMIT 8)
t)
(my-assert
(>= ARRAY-TOTAL-SIZE-LIMIT 1024)
t)
;;; simple-vector-p
(my-assert
(simple-vector-p (make-array 6))
t)
(my-assert
(simple-vector-p "aaaaaa")
nil)
(my-assert
(simple-vector-p (make-array 6 :fill-pointer t))
nil)
;;; svref
(my-assert
(simple-vector-p (setq v (vector 1 2 'sirens)))
t)
(my-assert
(svref v 0)
1)
(my-assert
(svref v 2)
SIRENS)
(my-assert
(setf (svref v 1) 'newcomer)
NEWCOMER )
(my-assert
v
#(1 NEWCOMER SIRENS))
;;; vector
(my-assert
(arrayp (setq v (vector 1 2 'sirens)))
t)
(my-assert
(vectorp v)
t)
(my-assert
(simple-vector-p v)
t )
(my-assert
(length v)
3)
;;; vector-pop
(my-assert
(vector-push (setq fable (list 'fable))
(setq fa (make-array 8
:fill-pointer 2
:initial-element 'sisyphus)))
2 )
(my-assert
(fill-pointer fa)
3 )
(my-assert
(eq (vector-pop fa) fable)
t)
(my-assert
(vector-pop fa)
SISYPHUS )
(my-assert
(fill-pointer fa)
1 )
;;; vector-push
(my-assert
(vector-push (setq fable (list 'fable))
(setq fa (make-array 8
:fill-pointer 2
:initial-element 'first-one)))
2)
(my-assert
(fill-pointer fa)
3 )
(my-assert
(eq (aref fa 2) fable)
t)
(my-assert
(vector-push-extend #\X
(setq aa
(make-array 5
:element-type 'character
:adjustable t
:fill-pointer 3)))
3)
(my-assert
(fill-pointer aa)
4 )
(my-assert
(vector-push-extend #\Y aa 4)
4 )
(my-assert
(>= (array-total-size aa) 5)
t)
(my-assert
(vector-push-extend #\Z aa 4)
5 )
(my-assert
(>= (array-total-size aa) 9)
t)
;;; vectorp
(my-assert
(vectorp "aaaaaa")
t)
(my-assert
(vectorp (make-array 6 :fill-pointer t))
t)
(my-assert
(vectorp (make-array '(2 3 4)))
nil)
(my-assert
(vectorp #*11)
t)
(my-assert
(vectorp #b11)
nil)
;;; bit
(my-assert
(bit (setq ba (make-array 8
:element-type 'bit
:initial-element 1))
3)
1)
(my-assert
(setf (bit ba 3) 0)
0)
(my-assert
(bit ba 3)
0)
(my-assert
(sbit ba 5)
1)
(my-assert
(setf (sbit ba 5) 1)
1)
(my-assert
(sbit ba 5)
1)
;;; bit-and etc
(my-assert
(bit-and (setq ba #*11101010) #*01101011)
#*01101010)
(my-assert
(bit-and #*1100 #*1010)
#*1000 )
(my-assert
(bit-andc1 #*1100 #*1010)
#*0010)
(my-assert
(setq rba (bit-andc2 ba #*00110011 t))
#*11001000)
(my-assert
(eq rba ba)
t)
(my-assert
(bit-not (setq ba #*11101010))
#*00010101)
(my-assert
(setq rba (bit-not ba
(setq tba (make-array 8
:element-type 'bit))))
#*00010101)
(my-assert
(equal rba tba)
t)
(my-assert
(bit-xor #*1100 #*1010)
#*0110)
;;; bit-vector-p
(my-assert
(bit-vector-p (make-array 6
:element-type 'bit
:fill-pointer t))
t)
(my-assert
(bit-vector-p #*)
t)
(my-assert
(bit-vector-p (make-array 6))
nil)
;;; simple-bit-vector
(my-assert
(simple-bit-vector-p (make-array 6))
nil)
(my-assert
(simple-bit-vector-p #*)
t)

240
src/ansi-tests/section16.lisp Normal file
View file

@ -0,0 +1,240 @@
;;; section 16: strings -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
;;; simple-string-p
(my-assert
(simple-string-p "aaaaaa")
t)
(my-assert
(simple-string-p (make-array 6
:element-type 'character
:fill-pointer t))
nil)
;;; char
(my-assert
(setq my-simple-string (make-string 6 :initial-element #\A))
"AAAAAA")
(my-assert
(schar my-simple-string 4)
#\A)
(my-assert
(setf (schar my-simple-string 4) #\B)
#\B)
(my-assert
my-simple-string
"AAAABA")
(my-assert
(setq my-filled-string
(make-array 6 :element-type 'character
:fill-pointer 5
:initial-contents my-simple-string))
"AAAAB")
(my-assert
(char my-filled-string 4)
#\B)
(my-assert
(char my-filled-string 5)
#\A
"char: ...
char ignores fill pointers when accessing elements. ")
(my-assert
(setf (char my-filled-string 3) #\C)
#\C)
(my-assert
(setf (char my-filled-string 5) #\D)
#\D
"char: ...
char ignores fill pointers when accessing elements. ")
(my-assert
(setf (fill-pointer my-filled-string) 6)
6)
(my-assert
my-filled-string
"AAACBD")
;;; string
(my-assert
(string "already a string")
"already a string")
(my-assert
(string 'elm)
"ELM")
(my-assert
(string #\c)
"c")
;;; string-upcase
(my-assert
(string-upcase "abcde")
"ABCDE")
(my-assert
(string-upcase "Dr. Livingston, I presume?")
"DR. LIVINGSTON, I PRESUME?")
(my-assert
(string-upcase "Dr. Livingston, I presume?" :start 6 :end 10)
"Dr. LiVINGston, I presume?")
(my-assert
(string-downcase "Dr. Livingston, I presume?")
"dr. livingston, i presume?")
(my-assert
(string-capitalize "elm 13c arthur;fig don't")
"Elm 13c Arthur;Fig Don'T")
(my-assert
(string-capitalize " hello ")
" Hello ")
(my-assert
(string-capitalize "occlUDeD cASEmenTs FOreSTAll iNADVertent DEFenestraTION")
"Occluded Casements Forestall Inadvertent Defenestration")
(my-assert
(string-capitalize 'kludgy-hash-search)
"Kludgy-Hash-Search")
(my-assert
(string-capitalize "DON'T!")
"Don'T!") ;not "Don't!"
(my-assert
(string-capitalize "pipe 13a, foo16c")
"Pipe 13a, Foo16c")
(my-assert
(setq str (copy-seq "0123ABCD890a"))
"0123ABCD890a")
(my-assert
(nstring-downcase str :start 5 :end 7)
"0123AbcD890a")
(my-assert
str
"0123AbcD890a")
;;; string-trim
(my-assert
(string-trim "abc" "abcaakaaakabcaaa")
"kaaak")
(my-assert
(string-trim '(#\Space #\Tab #\Newline) " garbanzo beans
")
"garbanzo beans")
(my-assert
(string-trim " (*)" " ( *three (silly) words* ) ")
"three (silly) words")
(my-assert
(string-left-trim "abc" "labcabcabc")
"labcabcabc")
(my-assert
(string-left-trim " (*)" " ( *three (silly) words* ) ")
"three (silly) words* ) ")
(my-assert
(string-right-trim " (*)" " ( *three (silly) words* ) ")
" ( *three (silly) words")
;;; string=
(my-assert
(string= "foo" "foo")
t)
(my-assert
(string= "foo" "Foo")
nil)
(my-assert
(string= "foo" "bar")
nil)
(my-assert
(string= "together" "frog" :start1 1 :end1 3 :start2 2)
t)
(my-assert
(string-equal "foo" "Foo")
t)
(my-assert
(string= "abcd" "01234abcd9012" :start2 5 :end2 9)
t)
(my-assert
(string< "aaaa" "aaab")
3)
(my-assert
(string>= "aaaaa" "aaaa")
4)
(my-assert
(string-not-greaterp "Abcde" "abcdE")
5)
(my-assert
(string-lessp "012AAAA789" "01aaab6" :start1 3 :end1 7
:start2 2 :end2 6)
6)
(my-assert
(string-not-equal "AAAA" "aaaA")
nil)
;;; stringp
(my-assert
(stringp "aaaaaa")
t)
(my-assert
(stringp #\a)
nil)
;;; make-string
(my-assert
(make-string 10 :initial-element #\5)
"5555555555")
(my-assert
(length (make-string 10))
10)

846
src/ansi-tests/section17.lisp Normal file
View file

@ -0,0 +1,846 @@
;;; section 17: sequences -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
;;; 17.2.1.1
(my-assert
(remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'equal)
(foo bar "BAR" "foo" "bar"))
(my-assert
(remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'equalp)
(foo bar "BAR" "bar"))
(my-assert
(remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'string-equal)
(bar "BAR" "bar"))
(my-assert
(remove "FOO" '(foo bar "FOO" "BAR" "foo" "bar") :test #'string=)
(BAR "BAR" "foo" "bar"))
(my-assert
(remove 1 '(1 1.0 #C(1.0 0.0) 2 2.0 #C(2.0 0.0)) :test-not #'eql)
(1))
(my-assert
(remove 1 '(1 1.0 #C(1.0 0.0) 2 2.0 #C(2.0 0.0)) :test-not #'=)
(1 1.0 #C(1.0 0.0)))
(my-assert
(remove 1 '(1 1.0 #C(1.0 0.0) 2 2.0 #C(2.0 0.0)) :test (complement #'=))
(1 1.0 #C(1.0 0.0)))
(my-assert
(count 1 '((one 1) (uno 1) (two 2) (dos 2)) :key #'cadr)
2)
(my-assert
(count 2.0 '(1 2 3) :test #'eql :key #'float)
1)
(my-assert
(count "FOO" (list (make-pathname :name "FOO" :type "X")
(make-pathname :name "FOO" :type "Y"))
:key #'pathname-name
:test #'equal)
2)
;;; 17.2.2.1
(my-assert
(count-if #'zerop '(1 #C(0.0 0.0) 0 0.0d0 0.0s0 3))
4)
(my-assert
(remove-if-not #'symbolp '(0 1 2 3 4 5 6 7 8 9 A B C D E F))
(A B C D E F))
(my-assert
(remove-if (complement #'symbolp) '(0 1 2 3 4 5 6 7 8 9 A B C D E F))
(A B C D E F))
(my-assert
(count-if #'zerop '("foo" "" "bar" "" "" "baz" "quux") :key #'length)
3)
;;; copy-seq
(my-assert
(let ((str "a string"))
str)
"a string")
(my-assert
(let ((str "a string"))
(equalp str (copy-seq str)))
t)
(my-assert
(let ((str "a string"))
(eql str (copy-seq str)))
nil)
;;; elt
(my-assert
(let ((str "a string"))
(setq str (copy-seq "0123456789")))
"0123456789")
(my-assert
(let ((str "a string"))
(setq str (copy-seq "0123456789"))
(elt str 6))
#\6)
(my-assert
(let ((str "a string"))
(setq str (copy-seq "0123456789"))
(setf (elt str 0) #\#))
#\#)
(my-assert
(let ((str "a string"))
(setq str (copy-seq "0123456789"))
(setf (elt str 0) #\#)
str)
"#123456789")
;;; fill
(my-assert
(fill (list 0 1 2 3 4 5) '(444))
((444) (444) (444) (444) (444) (444)))
(my-assert
(fill (copy-seq "01234") #\e :start 3)
"012ee")
(my-assert
(setq x (vector 'a 'b 'c 'd 'e))
#(A B C D E))
(my-assert
(fill x 'z :start 1 :end 3)
#(A Z Z D E))
(my-assert
x
#(A Z Z D E))
(my-assert
(fill x 'p)
#(P P P P P))
(my-assert
x
#(P P P P P))
;;; make-sequence
(my-assert
(make-sequence 'list 0)
())
(my-assert
(make-sequence 'string 26 :initial-element #\.)
"..........................")
(my-assert
(make-sequence '(vector double-float) 2
:initial-element 1d0)
#(1.0d0 1.0d0))
(my-assert
(make-sequence '(vector * 2) 3)
TYPE-ERROR)
(my-assert
(make-sequence '(vector * 4) 3)
TYPE-ERROR)
;;; subseq
(my-assert
(let ((str (copy-seq "012345")))
str)
"012345")
(my-assert
(let ((str (copy-seq "012345")))
(subseq str 2))
"2345")
(my-assert
(let ((str (copy-seq "012345")))
(subseq str 3 5))
"34")
(my-assert
(let ((str (copy-seq "012345")))
(setf (subseq str 4) "abc"))
"abc")
(my-assert
(let ((str (copy-seq "012345")))
(setf (subseq str 4) "abc")
str)
"0123ab")
(my-assert
(let ((str (copy-seq "012345")))
(setf (subseq str 4) "abc")
(setf (subseq str 0 2) "A"))
"A")
(my-assert
(let ((str (copy-seq "012345")))
(setf (subseq str 4) "abc")
(setf (subseq str 0 2) "A")
str)
"A123ab")
;;; map
(my-assert
(map 'string #'(lambda (x y)
(char "01234567890ABCDEF" (mod (+ x y) 16)))
'(1 2 3 4)
'(10 9 8 7))
"AAAA")
(my-assert
(let ((seq (map 'list #'copy-seq
'("lower" "UPPER" "" "123"))))
seq)
("lower" "UPPER" "" "123"))
(my-assert
(let ((seq (map 'list #'copy-seq
'("lower" "UPPER" "" "123"))))
(map nil #'nstring-upcase seq))
NIL)
(my-assert
(let ((seq (map 'list #'copy-seq
'("lower" "UPPER" "" "123"))))
(map nil #'nstring-upcase seq)
seq)
("LOWER" "UPPER" "" "123"))
(my-assert
(map 'list #'- '(1 2 3 4))
(-1 -2 -3 -4))
(my-assert
(map 'string
#'(lambda (x) (if (oddp x) #\1 #\0))
'(1 2 3 4))
"1010")
(my-assert
(map '(vector * 4) #'cons "abc" "de")
TYPE-ERROR)
;;; map-into
(my-assert
(setq a (list 1 2 3 4) b (list 10 10 10 10))
(10 10 10 10))
(my-assert
(map-into a #'+ a b)
(11 12 13 14))
(my-assert
a
(11 12 13 14))
(my-assert
b
(10 10 10 10))
(my-assert
(setq k '(one two three))
(ONE TWO THREE))
(my-assert
(map-into a #'cons k a)
((ONE . 11) (TWO . 12) (THREE . 13) 14))
;;; reduce
(my-assert
(reduce #'* '(1 2 3 4 5))
120)
(my-assert
(reduce #'append '((1) (2)) :initial-value '(i n i t))
(I N I T 1 2))
(my-assert
(reduce #'append '((1) (2)) :from-end t
:initial-value '(i n i t))
(1 2 I N I T))
(my-assert
(reduce #'- '(1 2 3 4))
-8)
(my-assert
(reduce #'- '(1 2 3 4) :from-end t)
-2)
(my-assert
(reduce #'+ '())
0)
(my-assert
(reduce #'+ '(3))
3)
(my-assert
(reduce #'+ '(foo))
FOO)
(my-assert
(reduce #'list '(1 2 3 4))
(((1 2) 3) 4))
(my-assert
(reduce #'list '(1 2 3 4) :from-end t)
(1 (2 (3 4))))
(my-assert
(reduce #'list '(1 2 3 4) :initial-value 'foo)
((((foo 1) 2) 3) 4))
(my-assert
(reduce #'list '(1 2 3 4)
:from-end t :initial-value 'foo)
(1 (2 (3 (4 foo)))))
;;; count
(my-assert
(count #\a "how many A's are there in here?")
2)
(my-assert
(count-if-not #'oddp '((1) (2) (3) (4)) :key #'car)
2)
(my-assert
(count-if #'upper-case-p "The Crying of Lot 49" :start 4)
2)
;; length
(my-assert
(length "abc")
3)
(my-assert
(setq str (make-array '(3) :element-type 'character
:initial-contents "abc"
:fill-pointer t))
"abc")
(my-assert
(length str)
3)
(my-assert
(setf (fill-pointer str) 2)
2)
(my-assert
(length str)
2)
;;; reverse
(my-assert
(setq str "abc")
"abc")
(my-assert
(reverse str)
"cba")
(my-assert
str
"abc")
(my-assert
(setq str (copy-seq str))
"abc")
(my-assert
(nreverse str)
"cba")
(my-assert
str
#+(or cmu sbcl clisp ecls) "cba"
#-(or cmu sbcl clisp ecls) fill-this-in)
(my-assert
(let ((l (list 1 2 3)))
l)
(1 2 3))
(my-assert
(let ((l (list 1 2 3)))
(nreverse l))
(3 2 1))
(my-assert
(let ((l (list 1 2 3)))
(nreverse l)
l)
#+(or cmu sbcl ecls) (1)
#+clisp (3 2 1)
#-(or cmu sbcl clisp ecls) fill-this-in)
;;; sort
(my-assert
(setq tester (copy-seq "lkjashd"))
"lkjashd")
(my-assert
(sort tester #'char-lessp)
"adhjkls")
(my-assert
(setq tester (list '(1 2 3) '(4 5 6) '(7 8 9)))
((1 2 3) (4 5 6) (7 8 9)))
(my-assert
(sort tester #'> :key #'car)
((7 8 9) (4 5 6) (1 2 3)))
(my-assert
(setq tester (list 1 2 3 4 5 6 7 8 9 0))
(1 2 3 4 5 6 7 8 9 0))
(my-assert
(stable-sort tester #'(lambda (x y) (and (oddp x) (evenp y))))
(1 3 5 7 9 2 4 6 8 0))
(my-assert
(sort (setq committee-data
(vector (list (list "JonL" "White") "Iteration")
(list (list "Dick" "Waters") "Iteration")
(list (list "Dick" "Gabriel") "Objects")
(list (list "Kent" "Pitman") "Conditions")
(list (list "Gregor" "Kiczales") "Objects")
(list (list "David" "Moon") "Objects")
(list (list "Kathy" "Chapman") "Editorial")
(list (list "Larry" "Masinter") "Cleanup")
(list (list "Sandra" "Loosemore") "Compiler")))
#'string-lessp :key #'cadar)
#((("Kathy" "Chapman") "Editorial")
(("Dick" "Gabriel") "Objects")
(("Gregor" "Kiczales") "Objects")
(("Sandra" "Loosemore") "Compiler")
(("Larry" "Masinter") "Cleanup")
(("David" "Moon") "Objects")
(("Kent" "Pitman") "Conditions")
(("Dick" "Waters") "Iteration")
(("JonL" "White") "Iteration")))
;; Note that individual alphabetical order within `committees'
;; is preserved.
(my-assert
(setq committee-data
(stable-sort committee-data #'string-lessp :key #'cadr))
#((("Larry" "Masinter") "Cleanup")
(("Sandra" "Loosemore") "Compiler")
(("Kent" "Pitman") "Conditions")
(("Kathy" "Chapman") "Editorial")
(("Dick" "Waters") "Iteration")
(("JonL" "White") "Iteration")
(("Dick" "Gabriel") "Objects")
(("Gregor" "Kiczales") "Objects")
(("David" "Moon") "Objects")))
;;; find
(my-assert
(find #\d "here are some letters that can be looked at" :test #'char>)
#\Space)
(my-assert
(find-if #'oddp '(1 2 3 4 5) :end 3 :from-end t)
3)
(my-assert
(find-if-not #'complexp
'#(3.5 2 #C(1.0 0.0) #C(0.0 1.0))
:start 2)
NIL)
;;; position
(my-assert
(position #\a "baobab" :from-end t)
4)
(my-assert
(position-if #'oddp '((1) (2) (3) (4)) :start 1 :key #'car)
2)
(my-assert
(position 595 '())
NIL)
(my-assert
(position-if-not #'integerp '(1 2 3 4 5.0))
4)
;;; search
(my-assert
(search "dog" "it's a dog's life")
7)
(my-assert
(search '(0 1) '(2 4 6 1 3 5) :key #'oddp)
2)
;;; mismatch
(my-assert
(mismatch "abcd" "ABCDE" :test #'char-equal)
4)
(my-assert
(mismatch '(3 2 1 1 2 3) '(1 2 3) :from-end t)
3)
(my-assert
(mismatch '(1 2 3) '(2 3 4) :test-not #'eq :key #'oddp)
NIL)
(my-assert
(mismatch '(1 2 3 4 5 6) '(3 4 5 6 7) :start1 2 :end2 4)
NIL)
;;; replace
(my-assert
(replace (copy-seq "abcdefghij")
"0123456789" :start1 4 :end1 7 :start2 4)
"abcd456hij")
(my-assert
(let ((lst (copy-seq "012345678")))
lst)
"012345678")
(my-assert
(let ((lst (copy-seq "012345678")))
(replace lst lst :start1 2 :start2 0))
"010123456")
(my-assert
(let ((lst (copy-seq "012345678")))
(replace lst lst :start1 2 :start2 0)
lst)
"010123456")
;;; substitute
(my-assert
(substitute #\. #\SPACE "0 2 4 6")
"0.2.4.6")
(my-assert
(substitute 9 4 '(1 2 4 1 3 4 5))
(1 2 9 1 3 9 5))
(my-assert
(substitute 9 4 '(1 2 4 1 3 4 5) :count 1)
(1 2 9 1 3 4 5))
(my-assert
(substitute 9 4 '(1 2 4 1 3 4 5) :count 1 :from-end t)
(1 2 4 1 3 9 5))
(my-assert
(substitute 9 3 '(1 2 4 1 3 4 5) :test #'>)
(9 9 4 9 3 4 5))
(my-assert
(substitute-if 0 #'evenp '((1) (2) (3) (4)) :start 2 :key #'car)
((1) (2) (3) 0))
(my-assert
(substitute-if 9 #'oddp '(1 2 4 1 3 4 5))
(9 2 4 9 9 4 9))
(my-assert
(substitute-if 9 #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t)
(1 2 4 1 3 9 5))
(my-assert
(setq some-things (list 'a 'car 'b 'cdr 'c))
(A CAR B CDR C))
(my-assert
(nsubstitute-if "function was here" #'fboundp some-things
:count 1 :from-end t)
(A CAR B "function was here" C))
(my-assert
some-things
(A CAR B "function was here" C))
(my-assert
(setq alpha-tester (copy-seq "ab "))
"ab ")
(my-assert
(nsubstitute-if-not #\z #'alpha-char-p alpha-tester)
"abz")
(my-assert
alpha-tester
"abz")
;;; concatenate
(my-assert
(concatenate 'string "all" " " "together" " " "now")
"all together now")
(my-assert
(concatenate 'list "ABC" '(d e f) #(1 2 3) #*1011)
(#\A #\B #\C D E F 1 2 3 1 0 1 1))
(my-assert
(concatenate 'list)
NIL)
(my-assert
(concatenate '(vector * 2) "a" "bc")
TYPE-ERROR)
;;; merge
(my-assert
(setq test1 (list 1 3 4 6 7))
(1 3 4 6 7))
(my-assert
(setq test2 (list 2 5 8))
(2 5 8))
(my-assert
(merge 'list test1 test2 #'<)
(1 2 3 4 5 6 7 8))
(my-assert
(setq test1 (copy-seq "BOY"))
"BOY")
(my-assert
(setq test2 (copy-seq "nosy"))
"nosy")
(my-assert
(merge 'string test1 test2 #'char-lessp)
"BnOosYy")
(my-assert
(setq test1 (vector '(red . 1) '(blue . 4)))
#((RED . 1) (BLUE . 4)))
(my-assert
(setq test2 (vector '(yellow . 2) '(green . 7)))
#((YELLOW . 2) (GREEN . 7)))
(my-assert
(merge 'vector test1 test2 #'< :key #'cdr)
#((RED . 1) (YELLOW . 2) (BLUE . 4) (GREEN . 7)))
(my-assert
(merge '(vector * 4) '(1 5) '(2 4 6) #'<)
TYPE-ERROR)
;;; remove
(my-assert
(remove 4 '(1 3 4 5 9))
(1 3 5 9))
(my-assert
(remove 4 '(1 2 4 1 3 4 5))
(1 2 1 3 5))
(my-assert
(remove 4 '(1 2 4 1 3 4 5) :count 1)
(1 2 1 3 4 5))
(my-assert
(remove 4 '(1 2 4 1 3 4 5) :count 1 :from-end t)
(1 2 4 1 3 5))
(my-assert
(remove 3 '(1 2 4 1 3 4 5) :test #'>)
(4 3 4 5))
(my-assert
(setq lst '(list of four elements))
(LIST OF FOUR ELEMENTS))
(my-assert
(setq lst2 (copy-seq lst))
(LIST OF FOUR ELEMENTS))
(my-assert
(setq lst3 (delete 'four lst))
(LIST OF ELEMENTS))
(my-assert
(equal lst lst2)
nil)
(my-assert
(remove-if #'oddp '(1 2 4 1 3 4 5))
(2 4 4))
(my-assert
(remove-if #'evenp '(1 2 4 1 3 4 5) :count 1 :from-end t)
(1 2 4 1 3 5))
(my-assert
(remove-if-not #'evenp '(1 2 3 4 5 6 7 8 9) :count 2 :from-end t)
(1 2 3 4 5 6 8))
(my-assert
(setq tester (list 1 2 4 1 3 4 5))
(1 2 4 1 3 4 5))
(my-assert
(delete 4 tester)
(1 2 1 3 5))
(my-assert
(setq tester (list 1 2 4 1 3 4 5))
(1 2 4 1 3 4 5))
(my-assert
(delete 4 tester :count 1)
(1 2 1 3 4 5))
(my-assert
(setq tester (list 1 2 4 1 3 4 5))
(1 2 4 1 3 4 5))
(my-assert
(delete 4 tester :count 1 :from-end t)
(1 2 4 1 3 5))
(my-assert
(setq tester (list 1 2 4 1 3 4 5))
(1 2 4 1 3 4 5))
(my-assert
(delete 3 tester :test #'>)
(4 3 4 5))
(my-assert
(setq tester (list 1 2 4 1 3 4 5))
(1 2 4 1 3 4 5))
(my-assert
(delete-if #'oddp tester)
(2 4 4))
(my-assert
(setq tester (list 1 2 4 1 3 4 5))
(1 2 4 1 3 4 5))
(my-assert
(delete-if #'evenp tester :count 1 :from-end t)
(1 2 4 1 3 5))
(my-assert
(setq tester (list 1 2 3 4 5 6))
(1 2 3 4 5 6))
(my-assert
(delete-if #'evenp tester)
(1 3 5))
(my-assert
tester
#+(or cmu sbcl clisp ecls) (1 3 5)
#-(or cmu sbcl clisp ecls) fill-this-in)
(my-assert
(setq foo (list 'a 'b 'c))
(A B C))
(my-assert
(setq bar (cdr foo))
(B C))
(my-assert
(setq foo (delete 'b foo))
(A C))
(my-assert
bar
#+(or cmu sbcl clisp ecls) (B C)
#-(or cmu sbcl clisp ecls) fill-this-in)
; ((C))) or ...
(my-assert
(eq (cdr foo) (car bar))
#+(or cmu sbcl clisp ecls) nil
#-(or cmu sbcl clisp ecls) fill-this-in)
; T or ...
;;; remove-duplicates
(my-assert
(remove-duplicates "aBcDAbCd" :test #'char-equal :from-end t)
"aBcD")
(my-assert
(remove-duplicates '(a b c b d d e))
(A C B D E))
(my-assert
(remove-duplicates '(a b c b d d e) :from-end t)
(A B C D E))
(my-assert
(remove-duplicates '((foo #\a) (bar #\%) (baz #\A))
:test #'char-equal :key #'cadr)
((BAR #\%) (BAZ #\A)))
(my-assert
(remove-duplicates '((foo #\a) (bar #\%) (baz #\A))
:test #'char-equal :key #'cadr :from-end t)
((FOO #\a) (BAR #\%)))
(my-assert
(setq tester (list 0 1 2 3 4 5 6))
(0 1 2 3 4 5 6))
(my-assert
(delete-duplicates tester :key #'oddp :start 1 :end 6)
(0 4 5 6))

43
src/ansi-tests/section18-errors.lisp Normal file
View file

@ -0,0 +1,43 @@
;;; section 18 hash tables -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
(my-assert
(defvar *counters* (make-hash-table))
*COUNTERS*)
(my-assert
(multiple-value-bind (a b)
(gethash 'foo *counters*)
(list a b))
(NIL nil))
(my-assert
(multiple-value-bind (a b)
(gethash 'foo *counters* 0)
(list a b))
(0 nil))
(my-assert ; XXX
(defmacro how-many (obj) `(values (gethash ,obj *counters* 0)))
HOW-MANY)
(my-assert ; XXX
(defun count-it (obj) (incf (how-many obj)))
COUNT-IT)
(dolist (x '(bar foo foo bar bar baz)) (count-it x))
(my-assert
(how-many 'foo)
2)
(my-assert
(how-many 'bar)
3)
(my-assert
(how-many 'quux)
0)

385
src/ansi-tests/section18.lisp Normal file
View file

@ -0,0 +1,385 @@
;;; section 18 hash tables -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
(my-assert
(progn
(setq a (make-hash-table))
t)
t)
;; #<HASH-TABLE EQL 0/120 32536573>
(my-assert
(setf (gethash 'color a) 'brown)
BROWN)
(my-assert
(setf (gethash 'name a) 'fred)
FRED)
(my-assert
(multiple-value-bind (a b)
(gethash 'color a)
(list a b))
(BROWN t))
(my-assert
(multiple-value-bind (a b)
(gethash 'name a)
(list a b))
( FRED t))
(my-assert
(multiple-value-bind (a b)
(gethash 'pointy a)
(list a b))
( NIL nil))
;;;make-hash-table
(my-assert
(progn
(setq table (make-hash-table))
t)
t)
;; #<HASH-TABLE EQL 0/120 46142754>
(my-assert
(setf (gethash "one" table) 1)
1)
(my-assert
(multiple-value-bind (a b)
(gethash "one" table)
(list a b))
( NIL nil))
(my-assert
(progn
(setq table (make-hash-table :test 'equal))
t)
t)
; #<HASH-TABLE EQUAL 0/139 46145547>
(my-assert
(setf (gethash "one" table) 1)
1)
(my-assert
(multiple-value-bind (a b)
(gethash "one" table)
(list a b))
( 1 T))
(my-assert
(progn
(make-hash-table :rehash-size 1.5 :rehash-threshold 0.7)
t)
t)
; #<HASH-TABLE EQL 0/120 46156620>
;;; hash-table-p
(my-assert
(progn
(setq table (make-hash-table))
t)
t)
; #<HASH-TABLE EQL 0/120 32511220>
(my-assert
(hash-table-p table)
t)
(my-assert
(hash-table-p 37)
nil)
(my-assert
(hash-table-p '((a . 1) (b . 2)))
nil)
;; hash-table-count
(my-assert
(progn
(setq table (make-hash-table))
t)
t)
; #<HASH-TABLE EQL 0/120 32115135>
(my-assert
(hash-table-count table)
0)
(my-assert
(setf (gethash 57 table) "fifty-seven")
"fifty-seven")
(my-assert
(hash-table-count table)
1)
(my-assert
(dotimes (i 100) (setf (gethash i table) i))
NIL)
(my-assert
(hash-table-count table)
100)
;;; hash-table-rehash-size
(my-assert
(progn (setq table (make-hash-table :size 100 :rehash-size 1.4))
t)
t)
; #<HASH-TABLE EQL 0/100 2556371>
(my-assert
(hash-table-rehash-size table)
#-clisp 1.4
#+clisp 1.4s0)
;;; HASH-TABLE-REHASH-THRESHOLD
(my-assert
(progn
(setq table (make-hash-table :size 100 :rehash-threshold 0.5))
t)
t)
; #<HASH-TABLE EQL 0/100 2562446>
(my-assert
(hash-table-rehash-threshold table)
#-clisp 0.5
#+clisp 0.75s0)
;;; get-hash
(my-assert
(progn
(setq table (make-hash-table))
t)
t)
(my-assert
(multiple-value-bind (a b)
(gethash 1 table)
(list a b))
(NIL nil))
(my-assert
(multiple-value-bind (a b)
(gethash 1 table 2)
(list a b))
(2 nil))
(my-assert
(setf (gethash 1 table) "one")
"one")
(my-assert
(setf (gethash 2 table "two") "two")
"two")
(my-assert
(multiple-value-bind (a b)
(gethash 1 table)
(list a b))
("one" t))
(my-assert
(multiple-value-bind (a b)
(gethash 2 table)
(list a b))
("two" t))
(my-assert
(multiple-value-bind (a b)
(gethash nil table)
(list a b))
(NIL nil))
(my-assert
(setf (gethash nil table) nil)
NIL)
(my-assert
(multiple-value-bind (a b)
(gethash nil table)
(list a b))
(NIL t))
(unintern '*counters*)
(my-assert
(defvar *counters* (make-hash-table))
*COUNTERS*)
(my-assert
(multiple-value-bind (a b)
(gethash 'foo *counters*)
(list a b))
(NIL nil))
(my-assert
(multiple-value-bind (a b)
(gethash 'foo *counters* 0)
(list a b))
(0 nil))
;;; remhash
(setq table (make-hash-table))
(my-assert
(setf (gethash 100 table) "C")
"C")
(my-assert
(multiple-value-bind (a b)
(gethash 100 table)
(list a b))
("C" t))
(my-assert
(remhash 100 table)
t)
(my-assert
(multiple-value-bind (a b)
(gethash 100 table)
(list a b))
(NIL nil))
(my-assert
(remhash 100 table)
nil)
;;; maphash
(setq table (make-hash-table))
(my-assert
(dotimes (i 10) (setf (gethash i table) i))
NIL)
(my-assert
(let ((sum-of-squares 0))
(maphash #'(lambda (key val)
(let ((square (* val val)))
(incf sum-of-squares square)
(setf (gethash key table) square)))
table)
sum-of-squares)
285)
(my-assert
(hash-table-count table)
10)
(my-assert
(maphash #'(lambda (key val)
(when (oddp val) (remhash key table)))
table)
NIL)
(my-assert
(hash-table-count table)
5)
(my-assert
(let ((a nil))
(maphash #'(lambda (k v) (setq a (cons (list k v) a ))) table)
a)
#-clisp
((8 64) (6 36) (4 16) (2 4) (0 0))
#+clisp
((0 0) (2 4) (4 16) (6 36) (8 64)))
;;; with-hash-table-iterator
(my-assert
(defun test-hash-table-iterator (hash-table)
(let ((all-entries '())
(generated-entries '())
(unique (list nil)))
(maphash #'(lambda (key value) (push (list key value) all-entries))
hash-table)
(with-hash-table-iterator (generator-fn hash-table)
(loop
(multiple-value-bind (more? key value) (generator-fn)
(unless more? (return))
(unless (eql value (gethash key hash-table unique))
(error "Key ~S not found for value ~S" key value))
(push (list key value) generated-entries))))
(unless (= (length all-entries)
(length generated-entries)
(length (union all-entries generated-entries
:key #'car :test (hash-table-test hash-table))))
(error "Generated entries and Maphash entries don't correspond"))
t))
test-hash-table-iterator)
(my-assert
(test-hash-table-iterator table)
t)
;;; clrhash
(setq table (make-hash-table))
(my-assert
(dotimes (i 100) (setf (gethash i table) (format nil "~R" i)))
NIL)
(my-assert
(hash-table-count table)
100)
(my-assert
(multiple-value-bind (a b)
(gethash 57 table)
(list a b))
("fifty-seven" t))
(clrhash table)
(my-assert
(hash-table-count table)
0)
(my-assert
(multiple-value-bind (a b)
(gethash 57 table)
(list a b))
( NIL nil))
;;; sxhash
(my-assert
(= (sxhash (list 'list "ab")) (sxhash (list 'list "ab")))
t)
(my-assert
(= (sxhash "a") (sxhash (make-string 1 :initial-element #\a)))
t)
(my-assert
(let ((r (make-random-state)))
(= (sxhash r) (sxhash (make-random-state r))))
t)

6
src/ansi-tests/section19.lisp Normal file
View file

@ -0,0 +1,6 @@
;;; section 19: filenames -*- mode: lisp -*-
(in-package :cl-user)
;; nothing that meaningfull to test...

162
src/ansi-tests/section2.lisp Normal file
View file

@ -0,0 +1,162 @@
;;; 2.1.4.5.1 examples of mutiple escape characters -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
(my-assert
(eq 'abc 'ABC)
T)
(my-assert
(eq 'abc '|ABC|)
T)
(my-assert
(eq 'abc 'a|B|c)
T)
(my-assert
(eq 'abc '|abc|)
nil)
;;; 2.1.4.6.1
(my-assert
(eq 'abc '\A\B\C)
T)
(my-assert
(eq 'abc 'a\Bc)
T)
(my-assert
(eq 'abc '\ABC)
T)
(my-assert
(eq 'abc '\abc)
nil)
;;; 2.1.4.7.1
(my-assert
(length '(this-that))
1)
(my-assert
(length '(this - that))
3)
(my-assert
(length '(a
b))
2)
(my-assert
(+ 34)
34)
(my-assert
(+ 3 4)
7)
;;; 2.4.1
(my-assert
(cons 'this-one 'that-one)
(this-one . that-one))
;;; 2.4.3.1
(my-assert
'foo
FOO)
(my-assert
''foo
(QUOTE FOO))
(my-assert
(car ''foo)
QUOTE)
;;; 2.4.4.1
(my-assert
(+ 3 ; three
4)
7)
;;; 2.4.8.7
(my-assert
#B1101
13 )
(my-assert
#b101/11
5/3)
;;; 2.4.8.8
(my-assert
#o37/15
31/13)
(my-assert
#o777
511)
(my-assert
#o105
69)
;;; 2.4.8.9
(my-assert
#xF00
3840 )
(my-assert
#x105
261 )
;;; 2.4.8.10
(my-assert
#2r11010101
213)
(my-assert
#b11010101
213)
(my-assert
#b+11010101
213)
(my-assert
#o325
213)
(my-assert
#xD5
213)
(my-assert
#16r+D5
213)
(my-assert
#o-300
-192)
(my-assert
#3r-21010
-192)
(my-assert
#25R-7H
-192)
(my-assert
#xACCEDED
181202413)

6
src/ansi-tests/section20.lisp Normal file
View file

@ -0,0 +1,6 @@
;;; section 20 : files -*- mode: lisp -*-
(in-package :cl-user)
;;; too much trouble. too much external stuff

116
src/ansi-tests/section21.lisp Normal file
View file

@ -0,0 +1,116 @@
;;; section 21: streams -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(subtypep 'stream 't)
t)
(my-assert
(subtypep 'broadcast-stream 'stream)
t)
(my-assert
(subtypep 'concatenated-stream 'stream)
t)
(my-assert
(subtypep 'echo-stream 'stream)
t)
(my-assert
(subtypep 'file-stream 'stream)
t)
(my-assert
(subtypep 'string-stream 'stream)
t)
(my-assert
(subtypep 'synonym-stream 'stream)
t)
(my-assert
(subtypep 'two-way-stream 'stream)
t)
;;; input-stream-p
(my-assert
(input-stream-p *standard-input*)
t)
(my-assert
(input-stream-p *terminal-io*)
t)
(my-assert
(input-stream-p (make-string-output-stream))
nil)
(my-assert
(output-stream-p *standard-output*)
t)
(my-assert
(output-stream-p *terminal-io*)
t)
(my-assert
(output-stream-p (make-string-input-stream "jr"))
nil)
;;; open-stream-p
(my-assert
(open-stream-p *standard-input*)
t)
;;; read-byte
(my-assert
(with-open-file (s "/tmp/temp-bytes"
:direction :output
:element-type 'unsigned-byte)
(write-byte 101 s))
101)
(my-assert
(with-open-file (s "/tmp/temp-bytes" :element-type 'unsigned-byte)
(list (read-byte s) (read-byte s nil 'eof)))
(101 EOF))
;;; peek-char
(my-assert
(with-input-from-string (input-stream " 1 2 3 4 5")
(list (peek-char t input-stream)
(peek-char #\4 input-stream)
(peek-char nil input-stream)))
(#\1 #\4 #\4))
;;; read-char
(my-assert
(with-input-from-string (is "0123")
(let ((a nil))
(do ((c (read-char is) (read-char is nil 'the-end)))
((not (characterp c)))
(setq a (cons c a)))
a))
(#\3 #\2 #\1 #\0))
;;; make-concatenated-stream
(my-assert
(read (make-concatenated-stream
(make-string-input-stream "1")
(make-string-input-stream "2")))
12)

203
src/ansi-tests/section22.lisp Normal file
View file

@ -0,0 +1,203 @@
;;; section 22: printer -*- mode: lisp -*-
(in-package :cl-user)
;;; from : Raymond Toy <toy@rtp.ericsson.se>
(my-assert
(format nil "~V,,,'-A" 10 "abc")
"abc-------")
; 0123456789
(my-assert
(format nil "foo")
"foo")
(my-assert
(setq x 5)
5)
(my-assert
(format nil "The answer is ~D." x)
"The answer is 5.")
(my-assert
(format nil "The answer is ~3D." x)
"The answer is 5.")
(my-assert
(format nil "The answer is ~3,'0D." x)
"The answer is 005.")
(my-assert
(format nil "The answer is ~:D." (expt 47 x))
"The answer is 229,345,007.")
(my-assert
(setq y "elephant")
"elephant")
(my-assert
(format nil "Look at the ~A!" y)
"Look at the elephant!")
(my-assert
(setq n 3)
3)
(my-assert
(format nil "~D item~:P found." n)
"3 items found.")
(my-assert
(format nil "~R dog~:[s are~; is~] here." n (= n 1))
"three dogs are here.")
(my-assert
(format nil "~R dog~:*~[s are~; is~:;s are~] here." n)
"three dogs are here.")
(my-assert
(format nil "Here ~[are~;is~:;are~] ~:*~R pupp~:@P." n)
"Here are three puppies.")
(my-assert
(defun foo (x)
(format nil "~6,2F|~6,2,1,'*F|~6,2,,'?F|~6F|~,2F|~F"
x x x x x x))
FOO)
(my-assert
(foo 3.14159)
" 3.14| 31.42| 3.14|3.1416|3.14|3.14159")
(my-assert
(foo -3.14159)
" -3.14|-31.42| -3.14|-3.142|-3.14|-3.14159")
(my-assert
(foo 100.0)
"100.00|******|100.00| 100.0|100.00|100.0")
(my-assert
(foo 1234.0)
"1234.00|******|??????|1234.0|1234.00|1234.0")
(my-assert
(foo 0.006)
" 0.01| 0.06| 0.01| 0.006|0.01|0.006")
(my-assert
(defun foo (x)
(format nil
"~9,2,1,,'*E|~10,3,2,2,'?,,'$E|~
~9,3,2,-2,'%@E|~9,2E"
x x x x))
FOO)
(my-assert
(foo 3.14159)
" 3.14E+0| 31.42$-01|+.003E+03| 3.14E+0")
(my-assert
(foo -3.14159)
" -3.14E+0|-31.42$-01|-.003E+03| -3.14E+0")
(my-assert
(foo 1100.0)
" 1.10E+3| 11.00$+02|+.001E+06| 1.10E+3")
(my-assert
(foo 1100.0L0)
#-(or cmu sbcl) " 1.10L+3| 11.00$+02|+.001L+06| 1.10L+3"
#+(or cmu sbcl) " 1.10d+3| 11.00$+02|+.001d+06| 1.10d+3")
(my-assert
(foo 1.1E13)
"*********| 11.00$+12|+.001E+16| 1.10E+13")
(my-assert
(foo 1.1L120)
#-(or cmu sbcl) "*********|??????????|%%%%%%%%%|1.10L+120"
#+(or cmu sbcl) "*********|??????????|%%%%%%%%%|1.10d+120")
(my-assert
(defun foo (x)
(format nil "~9,2,1,,'*G|~9,3,2,3,'?,,'$G|~9,3,2,0,'%G|~9,2G"
x x x x))
foo)
(my-assert
(foo 0.0314159)
" 3.14E-2|314.2$-04|0.314E-01| 3.14E-2")
(my-assert
(foo 0.314159)
" 0.31 |0.314 |0.314 | 0.31 ")
(my-assert
(foo 3.14159)
" 3.1 | 3.14 | 3.14 | 3.1 ")
(my-assert
(foo 31.4159)
" 31. | 31.4 | 31.4 | 31. ")
(my-assert
(foo 314.159)
" 3.14E+2| 314. | 314. | 3.14E+2")
(my-assert
(foo 3141.59)
" 3.14E+3|314.2$+01|0.314E+04| 3.14E+3")
(my-assert
(foo 3141.59L0)
#-(or cmu sbcl) " 3.14L+3|314.2$+01|0.314L+04| 3.14L+3"
#+(or cmu sbcl) " 3.14d+3|314.2$+01|0.314d+04| 3.14d+3")
(my-assert
(foo 3.14E12)
"*********|314.0$+10|0.314E+13| 3.14E+12")
(my-assert
(foo 3.14L120)
#-(or cmu sbcl) "*********|?????????|%%%%%%%%%|3.14L+120"
#+(or cmu sbcl) "*********|?????????|%%%%%%%%%|3.14d+120")
(my-assert
(format nil "~10<foo~;bar~>")
"foo bar")
(my-assert
(format nil "~10:<foo~;bar~>")
" foo bar")
(my-assert
(format nil "~10<foobar~>")
" foobar")
(my-assert
(format nil "~10:<foobar~>")
" foobar")
(my-assert
(format nil "~10:@<foo~;bar~>")
#+(or sbcl cmu ecls)
" foo bar "
#+clisp
" foo bar "
#-(or sbcl cmu clisp ecls)
fill-this-in)
(my-assert
(format nil "~10@<foobar~>")
"foobar ")
(my-assert
(format nil "~10:@<foobar~>")
" foobar ")
(my-assert
(FORMAT NIL "Written to ~A." #P"foo.bin")
"Written to foo.bin.")

1073
src/ansi-tests/section3.lisp Normal file
View file

File diff suppressed because it is too large Load diff

355
src/ansi-tests/section4.lisp Normal file
View file

@ -0,0 +1,355 @@
;;; types -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
;;coerce
(my-assert
(coerce '(a b c) 'vector)
#(A B C))
(my-assert
(coerce '(a b c) 'list)
(A B C))
(my-assert
(coerce '(#\A #\B #\C) 'string)
"ABC")
(my-assert
(coerce #(a b c) 'vector)
#(A B C))
(my-assert
(coerce #(a b c) 'list)
(A B C))
(my-assert
(coerce #(#\A #\B #\C) 'string)
"ABC")
(my-assert
(coerce "ABC" 'vector)
#(#\A #\B #\C))
(my-assert
(coerce "ABC" 'list)
(#\A #\B #\C))
(my-assert
(coerce "ABC" 'string)
"ABC")
(my-assert
(coerce '(a b c) '(vector * 3))
#(A B C))
(my-assert
(coerce '(a b c) 'list)
(A B C))
(my-assert
(coerce '(#\A #\B #\C) '(string 3))
"ABC")
(my-assert
(coerce #(a b c) '(vector * 3))
#(A B C))
(my-assert
(coerce #(a b c) 'list)
(A B C))
(my-assert
(coerce #(#\A #\B #\C) '(string 3))
"ABC")
(my-assert
(coerce "ABC" '(vector * 3))
#(#\A #\B #\C))
(my-assert
(coerce "ABC" 'list)
(#\A #\B #\C))
(my-assert
(coerce "ABC" '(string 3))
"ABC")
(my-assert
(coerce 'a 'character)
#\A)
(my-assert
(coerce 4.56 'complex)
#C(4.56 0.0))
(my-assert
(coerce 4.5s0 'complex)
#C(4.5s0 0.0s0))
(my-assert
(coerce 7/2 'complex)
7/2)
(my-assert
(coerce 0 'short-float)
0.0s0)
(my-assert
(coerce 3.5L0 'float)
3.5L0)
(my-assert
(coerce 7/2 'float)
3.5)
(my-assert
(coerce (cons 1 2) t)
(1 . 2))
(my-assert
(coerce '(a b c) '(vector * 4))
type-error)
(my-assert
(coerce #(a b c) '(vector * 4))
type-error)
(my-assert
(coerce '(a b c) '(vector * 2))
type-error)
(my-assert
(coerce #(a b c) '(vector * 2))
type-error)
(my-assert
(coerce "foo" '(string 2))
type-error)
(my-assert
(coerce #(#\a #\b #\c) '(string 2))
type-error)
(my-assert
(coerce '(0 1) '(simple-bit-vector 3))
type-error)
;; subtypep
(my-assert
(multiple-value-bind (a b)
(subtypep 'compiled-function 'function)
(list a b))
(T T)
"Type COMPILED-FUNCTION
Supertypes:
compiled-function, function, t
...
")
(my-assert
(multiple-value-bind (a b)
(subtypep 'null 'list)
(list a b))
(T T))
(my-assert
(multiple-value-bind (a b)
(subtypep 'null 'symbol)
(list a b))
(T T))
(my-assert
(multiple-value-bind (a b)
(subtypep 'integer 'string)
(list a b))
(nil #-clisp T
#+clisp nil))
(my-assert
(multiple-value-bind (a b)
(subtypep '(satisfies dummy) nil)
(list a b))
(nil #-clisp t
#+clisp nil))
(my-assert
(multiple-value-bind (a b)
(subtypep '(integer 1 3) '(integer 1 4))
(list a b))
(T T))
(my-assert
(multiple-value-bind (a b)
(subtypep '(member) 'nil)
(list a b))
(T T)) ; true, true ;or false, false
(my-assert
(multiple-value-bind (a b)
(subtypep 'nil '(member))
(list a b))
(T T)) ; true, true ;or false, false
;;; type-of
(my-assert
(type-of 'a)
SYMBOL )
(my-assert
(type-of '(1 . 2))
CONS)
; OR=> (CONS FIXNUM FIXNUM)
(my-assert
(type-of #c(0 1))
#-cmu COMPLEX
#+cmu (COMPLEX BIT))
; OR=> (COMPLEX INTEGER)
(my-assert
(defstruct temp-struct x y z)
TEMP-STRUCT)
(my-assert
(type-of (make-temp-struct))
TEMP-STRUCT)
(my-assert
(type-of "abc")
#+(or cmu sbcl clisp)
(SIMPLE-BASE-STRING 3)
#-(or cmu sbcl clisp)
STRING)
; OR=> (STRING 3)
(my-assert
(multiple-value-bind (a b)
(subtypep (type-of "abc") 'string)
(list a b))
(T T))
(my-assert
(type-of (expt 2 40))
BIGNUM)
; OR=> INTEGER
; OR=> (INTEGER 1099511627776 1099511627776)
; OR=> SYSTEM::TWO-WORD-BIGNUM
; OR=> FIXNUM
(my-assert
(multiple-value-bind (a b)
(subtypep (type-of 112312) 'integer)
(list a b))
(T T))
(my-assert
(defvar *foo* (make-array 5 :element-type t))
*FOO*)
(my-assert
(class-name (class-of *foo*))
#+(or cmu sbcl) SIMPLE-VECTOR
#-(or cmu sbcl) VECTOR)
(my-assert
(type-of *foo*)
#+(or cmu sbcl clisp)
(SIMPLE-VECTOR 5)
#-(or cmu sbcl clisp)
VECTOR)
; OR=> (VECTOR T 5)
;;; typep
(my-assert
(typep 12 'integer)
T)
(my-assert
(typep (1+ most-positive-fixnum) 'fixnum)
nil)
(my-assert
(typep nil t)
t)
(my-assert
(typep nil nil)
nil)
(my-assert
(typep 1 '(mod 2))
t )
(my-assert
(typep #c(1 1) '(complex (eql 1)))
t )
;; To understand this next example, you might need to refer to
;; Section 12.1.5.3 (Rule of Canonical Representation for Complex Rationals).
(my-assert
(typep #c(0 0) '(complex (eql 0)))
nil
"(upgraded-complex-part-type '(eql 0)) -> RATIONAL
a subtype of REAL. So it should work.
12.1.5.3:
also #C(5 0) is eql to 5
#C(5.0 0.0) is not eql to 5.0
CMUCL bombs here because of the eql. We give two
replacement tests below:
")
(my-assert
(typep #c(1 1) 'complex)
T
"Because #C(1 1) remains an complex")
(my-assert
(typep #c(3/2 0) 'complex)
NIL
"Because #C(3/2 0) is eql to 3/2")
(my-assert
(typep #c(1 0) 'complex)
NIL
"Because #c(0 0) is eql to 0")
(my-assert
(typep #c(0.0 0.0) 'complex)
T
"Because #c(0.0 0.0) remains a complex")
;;; type-error-datum
;;(my-assert
;;(progn
;; (defun fix-digits (condition)
;; (check-type condition type-error)
;; (let* ((digits '(zero one two three four
;; five six seven eight nine))
;; (val (position (type-error-datum condition) digits)))
;; (if (and val (subtypep 'number (type-error-expected-type condition)))
;; (store-value 7))))
;; (defun foo (x)
;; (handler-bind ((type-error #'fix-digits))
;; (check-type x number)
;; (+ x 3)))
;; t)
;;t)
;;(my-assert
;;(foo 'seven)
;;10)

2102
src/ansi-tests/section5.lisp Normal file
View file

File diff suppressed because it is too large Load diff

626
src/ansi-tests/section6.lisp Normal file
View file

@ -0,0 +1,626 @@
;;; 6.1.1.7 -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
;; Collect values by using FOR constructs.
(my-assert
(loop for numlist in '((1 2 4.0) (5 6 8.3) (8 9 10.4))
for a of-type integer = (first numlist)
and b of-type integer = (second numlist)
and c of-type float = (third numlist)
collect (list c b a))
((4.0 2 1) (8.3 6 5) (10.4 9 8)))
;; Destructuring simplifies the process.
(my-assert
(loop for (a b c) of-type (integer integer float) in
'((1 2 4.0) (5 6 8.3) (8 9 10.4))
collect (list c b a))
((4.0 2 1) (8.3 6 5) (10.4 9 8)))
;; If all the types are the same, this way is even simpler.
(my-assert
(loop for (a b c) of-type float in
'((1.0 2.0 4.0) (5.0 6.0 8.3) (8.0 9.0 10.4))
collect (list c b a))
((4.0 2.0 1.0) (8.3 6.0 5.0) (10.4 9.0 8.0)))
;; Initialize and declare variables in parallel by using the AND construct.
(my-assert
(loop for (a nil b) = '(1 2 3)
do (return (list a b)))
(1 3))
(my-assert
(loop for (x . y) = '(1 . 2)
do (return y))
2)
(my-assert
(loop for ((a . b) (c . d)) of-type ((float . float) (integer . integer)) in
'(((1.2 . 2.4) (3 . 4)) ((3.4 . 4.6) (5 . 6)))
collect (list a b c d))
((1.2 2.4 3 4) (3.4 4.6 5 6)))
;;; 6.1.2.1.1
(my-assert
(let ((xo 1)) (loop for i from xo by (incf xo) to 10 collect i))
(1 3 5 7 9))
;;; 6.1.2.1.2.1
(my-assert
(loop for (item . x) of-type (t . fixnum) in '((A . 1) (B . 2) (C . 3))
unless (eq item 'B) sum x)
4)
;;; 6.1.2.1.3.1
;; Collect successive tails of a list.
(my-assert
(loop for sublist on '(a b c d)
collect sublist)
((A B C D) (B C D) (C D) (D)))
;;; 6.1.2.1.4.1
;; Collect some numbers.
(my-assert
(loop for item = 1 then (+ item 10)
for iteration from 1 to 5
collect item)
(1 11 21 31 41))
;;;; 6.1.2.2
(my-assert
(loop with a = 1
with b = (+ a 2)
with c = (+ b 3)
return (list a b c))
(1 3 6))
(my-assert
(loop with a = 1
and b = 2
and c = 3
return (list a b c))
(1 2 3))
;;; 6.1.2.2.1
;; These bindings occur in sequence.
(my-assert
(loop with a = 1
with b = (+ a 2)
with c = (+ b 3)
return (list a b c))
(1 3 6))
;; These bindings occur in parallel.
(my-assert
(setq a 5 b 10)
10)
(my-assert
(loop with a = 1
and b = (+ a 2)
and c = (+ b 3)
return (list a b c))
(1 7 13))
;; This example shows a shorthand way to declare local variables
;; that are of different types.
(my-assert
(loop with (a b c) of-type (float integer float)
return (format nil "~A ~A ~A" a b c))
"0.0 0 0.0")
;; This example shows a shorthand way to declare local variables
;; that are the same type.
(my-assert
(loop with (a b c) of-type float
return (format nil "~A ~A ~A" a b c))
"0.0 0.0 0.0")
;;; 6.1.3
;; Collect every name and the kids in one list by using
;; COLLECT and APPEND.
(my-assert
(loop for name in '(fred sue alice joe june)
for kids in '((bob ken) () () (kris sunshine) ())
collect name
append kids)
(FRED BOB KEN SUE ALICE JOE KRIS SUNSHINE JUNE))
;;; 6.1.3.1
;; Collect all the symbols in a list.
(my-assert
(loop for i in '(bird 3 4 turtle (1 . 4) horse cat)
when (symbolp i) collect i)
(BIRD TURTLE HORSE CAT))
;; Collect and return odd numbers.
(my-assert
(loop for i from 1 to 10
if (oddp i) collect i)
(1 3 5 7 9))
;; Collect items into local variable, but don't return them.
(my-assert
(loop for i in '(a b c d) by #'cddr
collect i into my-list
finally my-list) ;;; hmm
nil )
;;; 6.1.3.2
;; Use APPEND to concatenate some sublists.
(my-assert
(loop for x in '((a) (b) ((c)))
append x)
(A B (C)))
;; NCONC some sublists together. Note that only lists made by the
;; call to LIST are modified.
(my-assert
(loop for i upfrom 0
as x in '(a b (c))
nconc (if (evenp i) (list x) nil))
(A (C)))
;;; 6.1.3.3
(my-assert
(loop for i in '(a b nil c nil d e)
count i)
5)
;;; 6.1.3.4
(my-assert
(loop for i in '(2 1 5 3 4)
maximize i)
5)
(my-assert
(loop for i in '(2 1 5 3 4)
minimize i)
1)
;; In this example, FIXNUM applies to the internal variable that holds
;; the maximum value.
(my-assert
(setq series '(1.2 4.3 5.7))
(1.2 4.3 5.7))
(my-assert
(loop for v in series
maximize (round v) of-type fixnum)
6)
;; In this example, FIXNUM applies to the variable RESULT.
(my-assert
(loop for v of-type float in series
minimize (round v) into result of-type fixnum
finally (return result))
1)
;;; 6.1.3.5
(my-assert
(loop for i of-type fixnum in '(1 2 3 4 5)
sum i)
15)
(my-assert
(setq series '(1.2 4.3 5.7))
(1.2 4.3 5.7))
(my-assert
(loop for v in series
sum (* 2.0 v))
22.4)
;;; 6.1.4.2
;; Make sure I is always less than 11 (two ways).
;; The FOR construct terminates these loops.
(my-assert
(loop for i from 0 to 10
always (< i 11))
T)
(my-assert
(loop for i from 0 to 10
never (> i 11))
T)
;; If I exceeds 10 return I; otherwise, return NIL.
;; The THEREIS construct terminates this loop.
(my-assert
(loop for i from 0
thereis (when (> i 10) i) )
11)
;;; The FINALLY clause is not evaluated in these examples.
(my-assert
(loop for i from 0 to 10
always (< i 9)
finally (format nil "you won't see this"))
NIL)
(my-assert
(loop never t
finally (format nil "you won't see this"))
NIL)
(my-assert
(loop thereis "Here is my value"
finally (format nil "you won't see this"))
"Here is my value")
;;; 6.1.4.3
;; Collect the length and the items of STACK.
(my-assert
(let ((stack '(a b c d e f)))
(loop for item = (length stack) then (pop stack)
collect item
while stack))
(6 A B C D E F))
;; Use WHILE to terminate a loop that otherwise wouldn't terminate.
;; Note that WHILE occurs after the WHEN.
(my-assert
(loop for i fixnum from 3
when (oddp i) collect i
while (< i 5))
(3 5))
;;; 6.1.6.1
;; Signal an exceptional condition.
(my-assert
(loop for item in '(1 2 3 a 4 5)
when (not (numberp item))
return (cerror "enter new value" "non-numeric value: ~s" item))
ERROR)
;; The previous example is equivalent to the following one.
(my-assert
(loop for item in '(1 2 3 a 4 5)
when (not (numberp item))
do (return
(cerror "Enter new value" "non-numeric value: ~s" item)))
ERROR)
;; This example parses a simple printed string representation from
;; BUFFER (which is itself a string) and returns the index of the
;; closing double-quote character.
(my-assert
(let ((buffer "\"a\" \"b\""))
(loop initially (unless (char= (char buffer 0) #\")
(loop-finish))
for i of-type fixnum from 1 below (length (the string buffer))
when (char= (char buffer i) #\")
return i))
2)
;; The collected value is returned.
(my-assert
(loop for i from 1 to 10
when (> i 5)
collect i
finally (prin1 'got-here))
(6 7 8 9 10) )
;; Return both the count of collected numbers and the numbers.
(my-assert
(multiple-value-bind (a b)
(loop for i from 1 to 10
when (> i 5)
collect i into number-list
and count i into number-count
finally (return (values number-count number-list)))
(list a b))
(5 (6 7 8 9 10)))
;;; 6.1.7.1.1
;; Just name and return.
(my-assert
(loop named max
for i from 1 to 10
do (print i)
do (return-from max 'done))
DONE)
;;; 6.1.8
(my-assert
(let ((i 0)) ; no loop keywords are used
(loop (incf i) (if (= i 3) (return i))))
3)
(my-assert
(let ((i 0)(j 0))
(tagbody
(loop (incf j 3) (incf i) (if (= i 3) (go exit)))
exit)
j)
9)
(my-assert
(loop for x from 1 to 10
for y = nil then x
collect (list x y))
((1 NIL) (2 2) (3 3) (4 4) (5 5) (6 6) (7 7) (8 8) (9 9) (10 10)))
(my-assert
(loop for x from 1 to 10
and y = nil then x
collect (list x y))
((1 NIL) (2 1) (3 2) (4 3) (5 4) (6 5) (7 6) (8 7) (9 8) (10 9)))
;;; 6.1.8.1
;; Group conditional clauses.
(my-assert
(multiple-value-bind (a b)
(loop for i in '(1 324 2345 323 2 4 235 252)
when (oddp i)
do (print i)
and collect i into odd-numbers
and do (terpri)
else ; I is even.
collect i into even-numbers
finally
(return (values odd-numbers even-numbers)))
(list a b))
((1 2345 323 235) (324 2 4 252)))
;; Collect numbers larger than 3.
(my-assert
(loop for i in '(1 2 3 4 5 6)
when (and (> i 3) i)
collect it) ; IT refers to (and (> i 3) i).
(4 5 6))
;; Find a number in a list.
(my-assert
(loop for i in '(1 2 3 4 5 6)
when (and (> i 3) i)
return it)
4)
;; The above example is similar to the following one.
(my-assert
(loop for i in '(1 2 3 4 5 6)
thereis (and (> i 3) i))
4)
;; Nest conditional clauses.
(my-assert
(multiple-value-bind (a b c)
(let ((list '(0 3.0 apple 4 5 9.8 orange banana)))
(loop for i in list
when (numberp i)
when (floatp i)
collect i into float-numbers
else ; Not (floatp i)
collect i into other-numbers
else ; Not (numberp i)
when (symbolp i)
collect i into symbol-list
else ; Not (symbolp i)
do (error "found a funny value in list ~S, value ~S~%" list i)
finally (return (values float-numbers other-numbers symbol-list))))
(list a b c))
((3.0 9.8) (0 4 5) (APPLE ORANGE BANANA)))
;;; do
(my-assert
(do ((temp-one 1 (1+ temp-one))
(temp-two 0 (1- temp-two)))
((> (- temp-one temp-two) 5) temp-one))
4)
(my-assert
(do ((temp-one 1 (1+ temp-one))
(temp-two 0 (1+ temp-one)))
((= 3 temp-two) temp-one))
3)
(my-assert
(do* ((temp-one 1 (1+ temp-one))
(temp-two 0 (1+ temp-one)))
((= 3 temp-two) temp-one))
2 )
(my-assert
(setq a-vector (vector 1 nil 3 nil))
#(1 nil 3 nil))
(my-assert
(do ((i 0 (+ i 1)) ;Sets every null element of a-vector to zero.
(n (array-dimension a-vector 0)))
((= i n))
(when (null (aref a-vector i))
(setf (aref a-vector i) 0)))
NIL)
(my-assert
a-vector
#(1 0 3 0))
;;; dotimes
(my-assert
(dotimes (temp-one 10 temp-one))
10)
(my-assert
(setq temp-two 0)
0)
(my-assert
(dotimes (temp-one 10 t) (incf temp-two))
T)
(my-assert
temp-two
10)
;;; True if the specified subsequence of the string is a
;;; palindrome (reads the same forwards and backwards).
(my-assert
(defun palindromep (string &optional
(start 0)
(end (length string)))
(dotimes (k (floor (- end start) 2) t)
(unless (char-equal (char string (+ start k))
(char string (- end k 1)))
(return nil))))
PALINDROMEP)
(my-assert
(palindromep "Able was I ere I saw Elba")
T)
(my-assert
(palindromep "A man, a plan, a canal--Panama!")
NIL)
(my-assert
(remove-if-not #'alpha-char-p ;Remove punctuation.
"A man, a plan, a canal--Panama!")
"AmanaplanacanalPanama")
(my-assert
(palindromep
(remove-if-not #'alpha-char-p
"A man, a plan, a canal--Panama!"))
T)
(my-assert
(palindromep
(remove-if-not
#'alpha-char-p
"Unremarkable was I ere I saw Elba Kramer, nu?"))
T)
(my-assert
(palindromep
(remove-if-not
#'alpha-char-p
"A man, a plan, a cat, a ham, a yak,
a yam, a hat, a canal--Panama!"))
T)
;;; dolist
(my-assert
(setq temp-two '())
NIL)
(my-assert
(dolist (temp-one '(1 2 3 4) temp-two) (push temp-one temp-two))
(4 3 2 1))
(my-assert
(setq temp-two 0)
0)
(my-assert
(dolist (temp-one '(1 2 3 4)) (incf temp-two))
NIL)
(my-assert
temp-two
4)
;;; loop-finish
;; Terminate the loop, but return the accumulated count.
(my-assert
(loop for i in '(1 2 3 stop-here 4 5 6)
when (symbolp i) do (loop-finish)
count i)
3)
;; The preceding loop is equivalent to:
(my-assert
(loop for i in '(1 2 3 stop-here 4 5 6)
until (symbolp i)
count i)
3)
;; While LOOP-FINISH can be used can be used in a variety of
;; situations it is really most needed in a situation where a need
;; to exit is detected at other than the loop's `top level'
;; (where UNTIL or WHEN often work just as well), or where some
;; computation must occur between the point where a need to exit is
;; detected and the point where the exit actually occurs. For example:
(my-assert
(defun tokenize-sentence (string)
(macrolet ((add-word (wvar svar)
`(when ,wvar
(push (coerce (nreverse ,wvar) 'string) ,svar)
(setq ,wvar nil))))
(loop with word = '() and sentence = '() and endpos = nil
for i below (length string)
do (let ((char (aref string i)))
(case char
(#\Space (add-word word sentence))
(#\. (setq endpos (1+ i)) (loop-finish))
(otherwise (push char word))))
finally (add-word word sentence)
(return (values (nreverse sentence) endpos)))))
TOKENIZE-SENTENCE)
(my-assert
(multiple-value-bind (a b)
(tokenize-sentence
"this is a sentence. this is another sentence.")
(list a b))
(("this" "is" "a" "sentence") 19))
(my-assert
(multiple-value-bind (a b)
(tokenize-sentence "this is a sentence")
(list a b))
(("this" "is" "a" "sentence") NIL))

48
src/ansi-tests/section7.lisp Normal file
View file

@ -0,0 +1,48 @@
;;; section 7: objects -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
;;; function-keywords
(my-assert
(progn
(defmethod gf1 ((a integer) &optional (b 2)
&key (c 3) ((:dee d) 4) e ((eff f)))
(list a b c d e f))
t)
T)
(my-assert
(eq (find-method #'gf1 '() (list (find-class 'integer))) 'nil)
nil) ; XXX
(my-assert
(multiple-value-list
(function-keywords (find-method #'gf1 '()
(list (find-class 'integer)))))
((:C :DEE :E EFF) nil))
(my-assert
(eq (defmethod gf2 ((a integer))
(list a b c d e f)) 'nil)
nil) ; XXX
(my-assert
(multiple-value-list
(function-keywords (find-method #'gf2 '() (list (find-class 'integer)))))
(() nil))
(my-assert
(progn
(defmethod gf3 ((a integer) &key b c d &allow-other-keys)
(list a b c d e f))
t)
t)
(my-assert
(multiple-value-list
(function-keywords (find-method #'gf3 '() (list (find-class 'integer)))))
((:B :C :D) t))
;;; if only i knew more about clos

200
src/ansi-tests/section8.lisp Normal file
View file

@ -0,0 +1,200 @@
;;; section 8 structures -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
;;;
;;; Example 1
;;; define town structure type
;;; area, watertowers, firetrucks, population, elevation are its components
;;;
(my-assert
(defstruct town
area
watertowers
(firetrucks 1 :type fixnum) ;an initialized slot
population
(elevation 5128 :read-only t)) ;a slot that can't be changed
TOWN)
;create a town instance
(my-assert
(progn
(setq town1 (make-town :area 0 :watertowers 0))
t)
t )
;town's predicate recognizes the new instance
(my-assert
(town-p town1)
t)
;new town's area is as specified by make-town
(my-assert
(town-area town1)
0)
;new town's elevation has initial value
(my-assert
(town-elevation town1)
5128)
;setf recognizes reader function
(my-assert
(setf (town-population town1) 99)
99)
(my-assert
(town-population town1)
99)
;copier function makes a copy of town1
(my-assert
(progn
(setq town2 (copy-town town1))
t)
t)
(my-assert
(= (town-population town1) (town-population town2))
t)
;since elevation is a read-only slot, its value can be set only
;when the structure is created
(my-assert
(progn
(setq town3 (make-town :area 0 :watertowers 3 :elevation 1200))
t)
t)
;;;
;;; Example 2
;;; define clown structure type
;;; this structure uses a nonstandard prefix
;;;
(my-assert
(defstruct (clown (:conc-name bozo-))
(nose-color 'red)
frizzy-hair-p polkadots)
CLOWN)
(my-assert
(progn
(setq funny-clown (make-clown))
t)
t)
;use non-default reader name
(my-assert
(bozo-nose-color funny-clown)
RED )
(my-assert
(defstruct (klown (:constructor make-up-klown) ;similar def using other
(:copier clone-klown) ;customizing keywords
(:predicate is-a-bozo-p))
nose-color frizzy-hair-p polkadots)
klown)
;custom constructor now exists
(my-assert
(fboundp 'make-up-klown)
t)
;;;
;;; Example 3
;;; define a vehicle structure type
;;; then define a truck structure type that includes
;;; the vehicle structure
;;;
(my-assert
(defstruct vehicle name year (diesel t :read-only t))
VEHICLE)
(my-assert
(defstruct (truck (:include vehicle (year 79)))
load-limit
(axles 6))
TRUCK)
(my-assert
(progn
(setq x (make-truck :name 'mac :diesel t :load-limit 17))
t)
t)
;vehicle readers work on trucks
(my-assert
(vehicle-name x)
MAC)
;default taken from :include clause
(my-assert
(vehicle-year x)
79 )
(my-assert
(defstruct (pickup (:include truck)) ;pickup type includes truck
camper long-bed four-wheel-drive)
PICKUP)
(my-assert
(progn
(setq x (make-pickup :name 'king :long-bed t))
t)
t)
;:include default inherited
(my-assert
(pickup-year x)
79)
;;;
;;; Example 4
;;; use of BOA constructors
;;;
(my-assert
(defstruct (dfs-boa ;BOA constructors
(:constructor make-dfs-boa (a b c))
(:constructor create-dfs-boa
(a &optional b (c 'cc) &rest d &aux e (f 'ff))))
a b c d e f)
DFS-BOA)
;a, b, and c set by position, and the rest are uninitialized
(my-assert
(progn
(setq x (make-dfs-boa 1 2 3))
t)
t)
(my-assert
(dfs-boa-a x)
1)
;a and b set, c and f defaulted
(my-assert
(progn
(setq x (create-dfs-boa 1 2))
t)
t)
(my-assert
(dfs-boa-b x)
2)
(my-assert
(eq (dfs-boa-c x) 'cc)
t)
;a, b, and c set, and the rest are collected into d
(my-assert
(progn
(setq x (create-dfs-boa 1 2 3 4 5 6))
t)
t)
(my-assert
(dfs-boa-d x)
(4 5 6))

127
src/ansi-tests/section9.lisp Normal file
View file

@ -0,0 +1,127 @@
;;; section 9: conditions -*- mode: lisp -*-
(in-package :cl-user)
(proclaim '(special log))
(my-assert
(subtypep 'arithmetic-error 'condition)
t)
(my-assert
(subtypep 'floating-point-overflow 'condition)
t)
(my-assert
(subtypep 'simple-type-error 'condition)
t)
(my-assert
(subtypep 'cell-error 'condition)
t)
(my-assert
(subtypep 'floating-point-underflow 'condition)
t)
(my-assert
(subtypep 'simple-warning 'condition)
t)
(my-assert
(subtypep 'condition 'condition)
t)
(my-assert
(subtypep 'package-error 'condition)
t)
(my-assert
(subtypep 'storage-condition 'condition)
t)
(my-assert
(subtypep 'control-error 'condition)
t)
(my-assert
(subtypep 'parse-error 'condition)
t)
(my-assert
(subtypep 'stream-error 'condition)
t)
(my-assert
(subtypep 'division-by-zero 'condition)
t)
(my-assert
(subtypep 'print-not-readable 'condition)
t)
(my-assert
(subtypep 'style-warning 'condition)
t)
(my-assert
(subtypep 'end-of-file 'condition)
t)
(my-assert
(subtypep 'program-error 'condition)
t)
(my-assert
(subtypep 'type-error 'condition)
t)
(my-assert
(subtypep 'error 'condition)
t)
(my-assert
(subtypep 'reader-error 'condition)
t)
(my-assert
(subtypep 'unbound-slot 'condition)
t)
(my-assert
(subtypep 'file-error 'condition)
t)
(my-assert
(subtypep 'serious-condition 'condition)
t)
(my-assert
(subtypep 'unbound-variable 'condition)
t)
(my-assert
(subtypep 'floating-point-inexact 'condition)
t)
(my-assert
(subtypep 'simple-condition 'condition)
t)
(my-assert
(subtypep 'undefined-function 'condition)
t)
(my-assert
(subtypep 'floating-point-invalid-operation 'condition)
t)
(my-assert
(subtypep 'simple-error 'condition)
t)
(my-assert
(subtypep 'warning 'condition)
t)

528
src/ansi-tests/setf.lisp Normal file
View file

@ -0,0 +1,528 @@
;;; based on v1.4 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(setf li1 '(a (b) ((c) (d)) ) vec1 '#(0 1 2 3))
#(0 1 2 3))
(my-assert
(setf pa 'old)
old)
(my-assert
(psetf pa 'new pao pa)
nil)
(my-assert
pa
new)
(my-assert
pao
old)
(my-assert
(setf (nth 1 li1) (quote uu))
uu)
(my-assert
(eval (quote li1))
(a uu ((c) (d))))
(my-assert
(setf (elt li1 1) (quote oo))
oo)
(my-assert
(setf (elt vec1 1) (quote oo))
oo)
(my-assert
(eval (quote li1))
(a oo ((c) (d))))
(my-assert
(eval (quote vec1))
#(0 oo 2 3))
(my-assert
(setf (rest li1) (quote ((ww))))
((ww)))
(my-assert
(eval (quote li1))
(a (ww)))
(my-assert
(setf (first li1) (quote aa))
aa)
(my-assert
(first li1)
aa)
(my-assert
(setf (second li1) (quote bb))
bb)
(my-assert
(eval (quote li1))
(aa bb))
(my-assert
(setf (third li1) (quote bb))
type-error)
(my-assert
(eval (quote li1))
(aa bb))
(my-assert
(setf (rest li1) (quote (2 3 4 5 6 7 8 9 10)))
(2 3 4 5 6 7 8 9 10))
(my-assert
(setf (second li1) 22)
22)
(my-assert
(eval (quote li1))
(aa 22 3 4 5 6 7 8 9 10))
(my-assert
(setf (third li1) (quote 33))
33)
(my-assert
(setf (fourth li1) (quote 44))
44)
(my-assert
(setf (fifth li1) (quote 55))
55)
(my-assert
(setf (sixth li1) (quote 66))
66)
(my-assert
(setf (seventh li1) (quote 77))
77)
(my-assert
(setf (eighth li1) (quote 88))
88)
(my-assert
(setf (ninth li1) (quote 99))
99)
(my-assert
(setf (tenth li1) (quote 1010))
1010)
(my-assert
(eval (quote li1))
(aa 22 33 44 55 66 77 88 99 1010))
(my-assert
(setf (first li1) (quote (((a)))))
(((a))))
(my-assert
(setf (caaar li1) (quote uu))
uu)
(my-assert
(caaar li1)
uu)
(my-assert
(car li1)
((uu)))
(my-assert
(setf (caar li1) (quote oo))
oo)
(my-assert
(eval (quote li1))
((oo) 22 33 44 55 66 77 88 99 1010))
(my-assert
(setf (car li1) (quote ii))
ii)
(my-assert
(eval (quote li1))
(ii 22 33 44 55 66 77 88 99 1010))
(my-assert
(setf (cdddr li1) (quote pp))
pp)
(my-assert
(eval (quote li1))
(ii 22 33 . pp))
(my-assert
(setf (caddr li1) (quote 333))
333)
(my-assert
(eval (quote li1))
(ii 22 333 . pp))
(my-assert
(setf (svref vec1 2) (quote kk))
kk)
(my-assert
(eval (quote vec1))
#(0 oo kk 3))
(my-assert
(setf (get (quote a) (quote b)) (quote uu))
uu)
(my-assert
(get (quote a) (quote b))
uu)
(my-assert
(setf (getf (cadr (setq xx (quote (aaa (i1 v1 i2 v2))))) (quote i2))
(quote v222))
v222)
(my-assert
(eval (quote xx))
(aaa (i1 v1 i2 v222)))
(my-assert
(getf (cadr xx) (quote i2))
v222)
(my-assert
(getf (cadr xx) (quote i1))
v1)
(my-assert
(setf (documentation (quote beispiel) (quote typ1)) "doc 1")
"doc 1")
(my-assert
(setf (documentation (quote beispiel) (quote typ2)) "doc 2")
"doc 2")
(my-assert
(documentation (quote beispiel) (quote typ2))
#+xcl (typ2 . "doc 2")
#-xcl "doc 2")
(my-assert
(setf (documentation (quote beispiel) (quote typ2)) "doc 3")
"doc 3")
(my-assert
(documentation (quote beispiel) (quote typ2))
#+xcl (typ2 . "doc 3")
#-xcl "doc 3")
(my-assert
(symbol-plist 'beispiel)
#+xcl (documentation ((typ2 . "doc 3") (typ1 . "doc 1")))
#+clisp (system::documentation-strings (typ2 "doc 3" typ1 "doc 1"))
#+allegro (excl::%documentation ((typ2 . "doc 3") (typ1 . "doc 1")))
#+(or cmu ecls) nil
#-(or xcl clisp allegro cmu ecls) unknown)
(my-assert
(setf (symbol-value (quote xx)) (quote voelligneu))
voelligneu)
(my-assert
(eval (quote xx))
voelligneu)
(my-assert
(progn
(setf (symbol-function (quote ff))
(coerce (quote (lambda (x) (print x) (quote hello))) (quote function)))
nil)
nil)
(my-assert
(ff 5)
hello)
(my-assert
(defun xx nil 'a)
xx)
(my-assert
(progn (setf (symbol-function 'xx1) (symbol-function 'xx)) nil)
nil)
(my-assert
(xx1)
a)
(my-assert
(setq l '(a 1 c d))
(a 1 c d))
(my-assert
(setf (the integer (cadr l)) 100)
100)
(my-assert
l
(a 100 c d))
(my-assert
(progn (setf a (make-hash-table)) t)
t)
(my-assert
(setf (gethash 'color a) 'brown)
brown)
(my-assert
(gethash 'color a)
brown)
(my-assert
(defstruct schiff masse)
schiff)
(my-assert
(progn (setf s1 (make-schiff)) nil)
nil)
(my-assert
(setf (schiff-masse s1) 500)
500)
(my-assert
(schiff-masse s1)
500)
(my-assert
(defmacro setf-test (v) `(svref ,v 3))
setf-test)
(my-assert
(progn (setf (macro-function 'setf-test1) (macro-function 'setf-test)) nil)
nil)
(my-assert
(setf (setf-test vec1) 'oho)
oho)
(my-assert
(eval 'vec1)
#(0 oo kk oho))
(my-assert
(setf (setf-test1 vec1) 'hihi)
hihi)
(my-assert
(eval 'vec1)
#(0 oo kk hihi))
;; (setf (displace ?? (svref vec1 3)) "aha")
;; aha
;; (eval 'vec1)
;; #(0 oo kk aha)
(my-assert
(progn (setf a (make-array '(4 3))) nil)
nil)
(my-assert
(aref a 2 2)
#+(or xcl cmu) 0
#+(or clisp akcl allegro ecls) nil
#-(or xcl clisp akcl allegro cmu ecls) unknown)
(my-assert
(setf (apply #'aref a '(2 2)) 'xxxx)
xxxx)
(my-assert
(aref a 2 2)
xxxx)
(my-assert
(setf (aref '#(a b c) 1) (quote ii))
ii)
(my-assert
(setf b #*101010)
#*101010)
(my-assert
(bit b 2)
1)
(my-assert
(setf (bit b 2) 0)
0)
(my-assert
(bit b 2)
0)
(my-assert
(setf (sbit b 2) 1)
1)
(my-assert
(sbit b 2)
1)
(my-assert
(progn (setf a (make-array 5 :fill-pointer t)) t)
t)
(my-assert
(fill-pointer a)
5)
(my-assert
(setf (fill-pointer a) 3)
3)
(my-assert
(fill-pointer a)
3)
(my-assert
(let ((str (copy-seq "hose")))
str)
"hose")
(my-assert
(let ((str (copy-seq "hose")))
(setf (char str 0) #\d))
#\d)
(my-assert
(let ((str (copy-seq "hose")))
(setf (char str 0) #\d)
str)
"dose")
(my-assert
(let ((str (copy-seq "hose")))
(setf (char str 0) #\d)
(setf str "aaaxxxccc"))
"aaaxxxccc")
(my-assert
(let ((str (copy-seq "hose")))
(setf (char str 0) #\d)
(setf str (copy-seq "aaaxxxccc"))
(setf (subseq str 3 6) "bbb"))
"bbb")
(my-assert
(let ((str (copy-seq "hose")))
(setf (char str 0) #\d)
(setf str (copy-seq "aaaxxxccc"))
(setf (subseq str 3 6) "bbb")
str)
"aaabbbccc")
(my-assert
(setq x (list 'a 'b 'c))
(a b c))
(my-assert
(shiftf (cadr x) 'z)
b)
(my-assert
x
(a z c))
(my-assert
(shiftf (cadr x) (cddr x) 'q)
z)
(my-assert
x
(a (c) . q))
(my-assert
(progn
(defun ad (x) (values (car x) (cdr x)))
(defsetf ad (x) (a b) `(setf (values (car ,x) (cdr ,x)) (values ,a ,b)))
(setq x (cons 1 2) y 3 z 4 w 5 v 6 u 7))
7)
(my-assert
(rotatef (ad x) (values y z) (values w v u))
nil)
(my-assert
x
(3 . 4))
(my-assert
(list y z w v u)
(5 6 1 2 nil))
(my-assert
(multiple-value-list
(shiftf (ad x)
(values y z w)
(values v u)
(floor 89 10)))
(3 4)
"(ad x) -> 3 and 4)
(y -> 5 z -> 6 w -> 1)
(v -> 2 u-> nil)
(floor 89 10) -> 8 and 9
so after shifting we expect:
x -> (5 . 6)
(y -> 2 z-> nil w -> nil)
(v -> 8 u -> 9)
and we return 3 and 4")
(my-assert
x
(5 . 6)
"check the shiftf result")
(my-assert
(list y z w v u)
(2 nil nil 8 9)
"check the shiftf result")
(my-assert
(progn (defsetf subseq (sequence start &optional end) (new-sequence)
`(progn (replace ,sequence ,new-sequence
:start1 ,start :end1 ,end)
,new-sequence)) t)
t)
(my-assert
(let (s)
(setf s (copy-seq "asdfg")
(subseq s 1 3) "xy"))
"xy")
(my-assert
(let (s)
(setf s (copy-seq "asdfg")
(subseq s 1 3) "xy")
s)
"axyfg")

560
src/ansi-tests/steele7.lisp Normal file
View file

@ -0,0 +1,560 @@
;;; based on v1.3 -*- mode: lisp -*-
(in-package :cl-user)
;;;
;;; testfile nach steele-beispielen
;;;
;; 7.3
(my-assert
(let ((f '+))
(apply f '(1 2)))
3)
(my-assert
(let ((f #'-))
(apply f '(1 2)))
-1)
(my-assert
(apply #'max 3 5 '(2 7 3))
7)
(my-assert
(apply 'cons '((+ 2 3) 4))
((+ 2 3) . 4))
(my-assert
(apply #'+ '())
0)
(my-assert
(apply #'(lambda (&key a b)(list a b)) '(:b 3))
(nil 3))
(my-assert
(funcall '+ 2 3)
5)
(my-assert
(let ((c (symbol-function '+)))
(funcall c 1 2 3 4))
10)
;;abschnitt 7.4
;; progn
(my-assert
(progn 1 2 3)
3)
(my-assert
(progn (+ 2 1) 2)
2)
(my-assert
(progn 1 2 (values 2 3))
2)
(my-assert
(progn)
nil)
;; prog1
(my-assert
(prog1 1 2 3)
1)
(my-assert
(prog1 3 (+ 1 2) 2)
3)
(my-assert
(prog1 (values 2 3) 1 2 )
2)
(my-assert
(let ((x '(a b c)))
(prog1 (car x)(rplaca x 'foo)))
a)
;; prog2
(my-assert
(prog2 1 2 3)
2)
(my-assert
(prog2 (+ 1 2) 2 3)
2)
(my-assert
(prog2 1 (values 2 3) 4)
2)
;; 7.5
;; let
(setf a 0)
(my-assert
(let ((a 1)(b 2) c)
(declare (integer a b))
(list a b c))
(1 2 nil))
(my-assert
(let ((a 1)
(b a))
(declare (integer a b))
(list a b))
(1 0))
(my-assert
(let (x239)
(declare (special x239))
(symbol-value 'x239))
nil)
;; let*
(my-assert
(let* ((a 1)(b 2) c )
(declare (integer a b))
(list a b c))
(1 2 nil))
(my-assert
(let* ((a 1)(b a))
(declare (integer a b))
(list a b))
(1 1))
;; compiler-let (?)
;; progv
(my-assert
(progv
'(a b c)
'(1 2 3)
(+ a b c))
6)
(unintern 'a)
(unintern 'b)
(unintern 'c)
(my-assert
(progv
'(a b c)
'(1 2)
(list a b c))
error)
(my-assert
(let ((v '(a b c))
(val '(3 2 1)))
(progv v val (mapcar #'eval v)))
(3 2 1))
;; flet
(my-assert
(flet ((plus (a b)(+ a b))
(minus (a b)(- a b)))
(list (plus 1 2)(minus 1 2)))
(3 -1))
(my-assert
(list (flet ( (+ (a b)(- a b)))(+ 3 2))(+ 3 2))
(1 5))
(my-assert
(flet ((+ (a b)(+ (+ a b a) b)))(+ 3 2))
10)
;; labels
(my-assert
(labels ((queue (l)(if (car l)(queue (cdr l))'ende)))(queue '(1 2 3)))
ende)
(my-assert
(labels ((+ (a b)(* a (+ a a b))))(+ 1 2 3))
error)
;; macrolet ?
;; 7.6
;; if
(my-assert
(let ((a t)(b nil))(list (if a 1 2)(if b 1 2)(if a 1)(if b 1)))
(1 2 1 nil))
;; when
(my-assert
(let ((a t)(b nil))(list (when a 1 2)(when b 1 2)(when a 1)))
(2 nil 1))
;; unless
(my-assert
(let ((a t)(b nil))(list (unless a 1 2)(unless b 1 2)(unless a 1)))
(nil 2 nil))
;; cond
(my-assert
(let ((a t)(b 10)(c nil))
(list (cond (a 1)(t 'end))(cond (b)(t 'end))(cond (c 1)(t 'end))))
(1 10 end))
;; case
(my-assert
(case (+ 1 2)
(1 -1)
(2 -2)
(3 -3))
-3)
(my-assert
(case (+ 1 2)
(1 -1)
(2 -2))
nil)
;; (case (+ 1 2)
;; (1 -1)
;; (2 -2)
;; (1 -1)
;; (3 -3))
;; error
(my-assert
(case (+ 1 2)
((1 3) -1)
(2 -2)
(otherwise 100))
-1)
;;
;; (case (+ 1 2)
;; ((1 3) -1)
;; ((2 1) -2)
;; (t 100))
;; error ;weil ein key nur einmal erscheinen darf!
;;
;; typecase
(my-assert
(typecase (+ 1 2)
(list -2)
(null -3)
(integer -1))
-1)
;; 7.7
;; block
(my-assert
(block blocktest (if t (return 0) ) 1)
error)
(my-assert
(block blocktest (if t (return-from blocktest 0) ) 1)
0)
(my-assert
(block blocktest (if nil (return-from blocktest 0) ) 1)
1)
(my-assert
(block blocktest (catch 'catcher
(if t (throw 'catcher 0) ) 1))
0)
;; 7.8
;; 7.8.1
;; loop
(my-assert
(let ((i 10))
(loop (if (< (decf i) 1)(return i))))
0)
(my-assert
(let ((i 10))
(catch 'catcher
(loop (if (< (decf i) 1)(return i)))))
0)
;; 7.8.2
;; do,do*
(setf a 0)
(my-assert
(do ((a 1 (+ a 1))(b a))
((> a 9) (list b c))
(setf c (+ a b)))
(0 9))
(my-assert
(do* ((a 1 (+ a 1))(b a))
((> a 9) b)
)
1)
(my-assert
(let ((a 0))
(do* ((a 1 (+ a 1))(b a))
((> a 9) a)
(declare (integer a b)))
a)
0)
;; 7.8.3
;; dolist
(my-assert
(let ((l '(1 2 3))
(r 0))
(dolist (x l r)
(setf r (+ r x)) ))
6)
;; dolist
(my-assert
(let ((l '(1 2 3)))
(dolist (x l)(if (> 0 x)(incf x)(return 10))))
10)
(my-assert
(let ((l '(1 2 3)))
(dolist (x l )(incf x)))
nil)
;; dotimes
(my-assert
(let ((s 0))
(dotimes (i (+ 1 9)s)
(setf s (+ s i))))
45)
;; 7.8.4
;; mapcar
(my-assert
(mapcar #'abs '(3 -4 2 -5 -6))
(3 4 2 5 6))
(my-assert
(mapcar #'cons '(a b c) '(1 2 3))
((a . 1) (b . 2) (c . 3)))
;; maplist
(my-assert
(maplist #'(lambda (x)(cons 'foo x))'(a b c d))
((foo a b c d)(foo b c d)(foo c d)(foo d)))
(my-assert
(maplist #'(lambda (x) (if (member (car x)(cdr x)) 0 1))
'(a b a c d b c))
(0 0 1 0 1 1 1))
;; mapc
(my-assert
(mapc #'abs '(3 -4 2 -5 -6))
(3 -4 2 -5 -6))
;; mapc
(my-assert
(mapl #'(lambda (x y)(cons x y))'(a b c d)'(1 2 3 4))
(a b c d))
;; mapcan
(my-assert
(mapcan #'(lambda (x)(and (numberp x)(list x)))'(a 1 b c 3 4 d 5))
(1 3 4 5))
;; mapcon
(my-assert
(mapcon #'(lambda (x)(and (oddp (car x))(list (car x))))'(5 4 3 2 1))
(5 3 1))
;; 7.8.5
;; tagbody
(my-assert
(let ((a 0))
(tagbody (if nil (go tag0) (go tag1))
(this will never be reached)
tag0
(setf a 1)
tag1
(setf a 2))
a)
2)
(my-assert
(let ((a 0))
(tagbody (if t (go tag0) (go tag1))
(this will never be reached)
tag0
(setf a 1)
)
a)
;; cmucl compiles on the fly and therefore signals an error
#-(or cmu sbcl) 1
#+(or cmu sbcl) error)
;; prog*
(my-assert
(let ((z '(1 0)))
(prog* ((y z)(x (car y)))
(return x)))
1)
(my-assert
(prog (a (b 1))
(if a (go tag0) (go tag1))
(this will never be reached)
tag0
(setf a 1)
(this will never be reached)
tag1
(setf a 2))
nil)
(my-assert
(prog (a (b 1))
(if a (return nil) (go tag1))
(this will never be reached)
tag0
(return (list a 1))
tag1
(setf a 2)
(go tag0))
(2 1))
;; 7.9
;; multiple-value-bind
(my-assert
(defun adder (x y)(values (+ 1 x)(+ 1 y) ) )
adder)
(my-assert
(multiple-value-bind (a b)(adder 1 2)(+ a b))
5)
(my-assert
(defun adder (x y)(values-list (list (+ 1 x)(+ 1 y))))
adder)
(my-assert
(multiple-value-bind (a b)(adder 1 2)(+ a b))
5)
(my-assert
(multiple-value-list (floor -3 4))
(-1 1))
(my-assert
(multiple-value-call #'+ (floor 5 3)(floor 19 4))
10)
(my-assert
(multiple-value-bind (c d)
(multiple-value-prog1 (floor -3 4) (+ 1 2))
(list c d))
(-1 1))
(my-assert
(multiple-value-bind (x)(floor 5 3)(list x))
(1))
(my-assert
(multiple-value-bind (x y)(floor 5 3)(list x y))
(1 2))
(my-assert
(multiple-value-bind (x y z)(floor 5 3)(list x y z))
(1 2 nil))
(my-assert
(multiple-value-setq
(a b)
(values 10 20))
10)
(my-assert
b
20)
(unintern 'a)
(unintern 'b)
;; 7.10
;; catch/throw/unwind-protect

1379
src/ansi-tests/streams.lisp Normal file
View file

File diff suppressed because it is too large Load diff

31
src/ansi-tests/streamslong.lisp Normal file
View file

@ -0,0 +1,31 @@
;;; based on v1.2 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(read-from-string "123")
123)
(my-assert
(prin1-to-string 123)
"123")
(my-assert
(let ((*a*
(make-array 10. :element-type 'character
:fill-pointer 0)))
(format *a* "XXX"))
nil)
(my-assert
(let ((*a*
(make-array 10. :element-type 'character
:fill-pointer 0)))
(format *a* "XXX")
*a*)
"XXX")
#+xcl
(my-assert
(sys::check-stream-system)
#+xcl t)

1600
src/ansi-tests/strings.lisp Normal file
View file

File diff suppressed because it is too large Load diff

706
src/ansi-tests/symbol10.lisp Normal file
View file

@ -0,0 +1,706 @@
;;; based on v1.2 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(progn (in-package :cl-user) nil)
nil
"in-package expects a 'string designator'
this is or a character, a symbol or a string.")
;; test der neuen valuezelle
;;; 1. ungebundenes symbol
(my-assert
(defun testvar (var)
(list (boundp var) ; gebunden
(if (boundp var)
(symbol-value var)
nil) ; wert/nil
(constantp var) ; konstante
#+xcl
(eq (sys::%p-get-cdr var 0)
sys::%cdr-specsym) ; specvar
#+clisp
(and (sys::special-variable-p var)
(not (constantp var))) ; specvar
#+allegro
(and (not (constantp var))
(eval `(let ((,var (list nil)))
(and (boundp ',var)
(eq (symbol-value ',var)
,var)))))
#+cmu
(eq (ext:info variable kind var)
':special);; like clisp
#+ecls
(si::specialp var)
#+sbcl
(eq (sb-int::info variable kind var)
':special);; like clisp
(and (fboundp var) t) ; funktion. eigenschaft
(and (fboundp var) (macro-function var) t) ; macro?
(and (fboundp var)
(special-operator-p var)
t) ; spezialform?
#-clisp
(and (symbol-plist var) t) ; p-liste?
#+clisp
(and (or (get var 'i1)
(get var 'i2)
(get var 'i3))
t) ; p-liste?
(get var 'i1) ; i1
(get var 'i2) ; i2
(get var 'i3) ; i3
) )
testvar)
(my-assert
(defun clrvar (var)
#+xcl
(subr 84 ;sys::%p-set-cdr-content
var 0 (sys::%p-get-content 'sys::%void-value 0) 0)
#-xcl
(progn (makunbound var) (fmakunbound var)
(setf (symbol-plist var) '()))
#+allegro
(setf (excl::symbol-bit var 'excl::.globally-special.) nil)
#+cmu
(setf (ext:info variable kind var) ':global)
#+sbcl
(setf (sb-int::info variable kind var) ':global)
var)
clrvar)
#+(or xcl clisp allegro cmu sbcl)
(my-assert
(progn (setf (symbol-function 'setf-get)
(symbol-function #+xcl 'sys::setf-get
#+clisp 'sys::%put
#+allegro 'excl::.inv-get
#+(or cmu sbcl) 'cl::%put)) t)
t)
;;; begin breitentest
(my-assert
(clrvar 'v1)
v1)
;;;; value - umbinden - macro - umbinden - props - umbinden
;;; value
(my-assert
(testvar 'v1)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil nil nil nil nil nil nil nil))
(my-assert
(setq v1 'val)
val)
(my-assert
(testvar 'v1)
;; geb val konst svar func mac spec plist i1 i2 i3
(t val nil nil nil nil nil nil nil nil nil))
;;; umbinden
(my-assert
(makunbound 'v1)
v1)
(my-assert
(testvar 'v1)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil nil nil nil nil nil nil nil))
(my-assert
(setq v1 'val2)
val2)
(my-assert
(testvar 'v1)
;; geb val konst svar func mac spec plist i1 i2 i3
(t val2 nil nil nil nil nil nil nil nil nil))
;;; macro
(my-assert
(defmacro v1 (x) (list 'quote x))
v1)
(my-assert
(testvar 'v1)
;; geb val konst svar func mac spec plist i1 i2 i3
(t val2 nil nil t t nil nil nil nil nil))
;;; umbinden
(my-assert
(fmakunbound 'v1)
v1)
(my-assert
(testvar 'v1)
;; geb val konst svar func mac spec plist i1 i2 i3
(t val2 nil nil nil nil nil nil nil nil nil))
(my-assert
(defmacro v1 (x) (list 'quote (list x x)))
v1)
(my-assert
(v1 33)
(33 33))
(my-assert
(testvar 'v1)
;; geb val konst svar func mac spec plist i1 i2 i3
(t val2 nil nil t t nil nil nil nil nil))
(my-assert
(makunbound 'v1)
v1)
(my-assert
(testvar 'v1)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil t t nil nil nil nil nil))
(my-assert
(setq v1 'val3)
val3)
(my-assert
(testvar 'v1)
;; geb val konst svar func mac spec plist i1 i2 i3
(t val3 nil nil t t nil nil nil nil nil))
;;; props
(my-assert
(setf-get 'v1 'i1 11)
11)
(my-assert
(setf-get 'v1 'i2 22)
22)
(my-assert
(setf-get 'v1 'i3 33)
33)
(my-assert
(testvar 'v1)
;; geb val konst svar func mac spec plist i1 i2 i3
(t val3 nil nil t t nil t 11 22 33))
;;; umbinden
(my-assert
(not (null (remprop 'v1 'i2)))
t)
(my-assert
(not (null (remprop 'v1 'i1)))
t)
(my-assert
(not (null (remprop 'v1 'i3)))
t)
(my-assert
(fmakunbound 'v1)
v1)
(my-assert
(makunbound 'v1)
v1)
(my-assert
(testvar 'v1)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil nil nil nil nil nil nil nil))
(my-assert
(setf-get 'v1 'i1 99)
99)
(my-assert
(defmacro v1 (x) (list 'quote (list x x x)))
v1)
(my-assert
(v1 a)
(a a a))
(my-assert
(setq v1 'val4)
val4)
(my-assert
(testvar 'v1)
;; geb val konst svar func mac spec plist i1 i2 i3
(t val4 nil nil t t nil t 99 nil nil))
;;; --- ende test1 -----
(my-assert
(clrvar 'v2)
v2)
;;; specvar - props - rebind - function
(my-assert
(defvar v2 'v2a)
v2)
(my-assert
(testvar 'v2)
;; geb val konst svar func mac spec plist i1 i2 i3
(t v2a nil t nil nil nil nil nil nil nil))
(my-assert
(setf-get 'v2 'i3 33)
33)
(my-assert
(setf-get 'v2 'i2 22)
22)
(my-assert
(setf-get 'v2 'i1 11)
11)
(my-assert
(testvar 'v2)
;; geb val konst svar func mac spec plist i1 i2 i3
(t v2a nil t nil nil nil t 11 22 33))
;;; rebind
(my-assert
(makunbound 'v2)
v2)
(my-assert
(not (null (remprop 'v2 'i1)))
t)
(my-assert
(not (null (remprop 'v2 'i2)))
t)
(my-assert
(not (null (remprop 'v2 'i3)))
t)
(my-assert
(testvar 'v2)
;; geb val konst svar func mac spec plist i1 i2 i3
#+xcl
(nil nil nil nil nil nil nil nil nil nil nil)
#-xcl
(nil nil nil t nil nil nil nil nil nil nil))
(my-assert
(defvar v2 'v2b)
v2)
(my-assert
(setf-get 'v2 'i1 111)
111)
(my-assert
(setf-get 'v2 'i2 222)
222)
(my-assert
(setf-get 'v2 'i3 333)
333)
(my-assert
(testvar 'v2)
;; geb val konst svar func mac spec plist i1 i2 i3
(t v2b nil t nil nil nil t 111 222 333))
;;; function
(my-assert
(defun v2 (x) (list x x))
v2)
(my-assert
(v2 44)
(44 44))
(my-assert
(testvar 'v2)
;; geb val konst svar func mac spec plist i1 i2 i3
(t v2b nil t t nil nil t 111 222 333 ))
(my-assert
(clrvar 'v3)
v3)
;;;;; function - con - rebind - prop
;;; function
(my-assert
(defun v3 (x y) (list x y))
v3)
(my-assert
(testvar 'v3)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil t nil nil nil nil nil nil))
;;; constant
(my-assert
(defconstant v3 99)
v3)
(my-assert
v3
99)
(my-assert
(v3 'a 'b)
(a b))
(my-assert
(testvar 'v3)
;; geb val konst svar func mac spec plist i1 i2 i3
(t 99 t nil t nil nil nil nil nil nil))
;;; rebind
(my-assert
(makunbound 'v3)
#+(or xcl allegro cmu sbcl) v3
#+(or clisp ecls) error)
(my-assert
(fmakunbound 'v3)
v3)
#+xcl
(my-assert
(testvar 'v3)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil nil nil nil nil nil nil nil))
(my-assert
(defconstant v3 999)
v3)
(my-assert
(defun v3 (x) (list x x))
v3)
(my-assert
(v3 'c)
(c c))
(my-assert
v3
999)
(my-assert
(testvar 'v3)
;; geb val konst svar func mac spec plist i1 i2 i3
(t 999 t nil t nil nil nil nil nil nil))
;;;defparameter
(my-assert
(defparameter var33)
error)
(my-assert
(defparameter var3 99)
var3)
(my-assert
var3
99)
(my-assert
(testvar 'var3)
;; geb val konst svar func mac spec plist i1 i2 i3
(t 99 nil t nil nil nil nil nil nil nil))
;;; rebind
(my-assert
(makunbound 'var3)
var3)
(my-assert
(testvar 'var3)
;; geb val konst svar func mac spec plist i1 i2 i3
#+xcl
(nil nil nil nil nil nil nil nil nil nil nil)
#-xcl
(nil nil nil t nil nil nil nil nil nil nil))
;;; props
(my-assert
(setf-get 'v3 'i2 222)
222)
(my-assert
(setf-get 'v3 'i1 111)
111)
(my-assert
(testvar 'v3)
;; geb val konst svar func mac spec plist i1 i2 i3
(t 999 t nil t nil nil t 111 222 nil))
(my-assert
(clrvar 'v4)
v4)
;;;; function - rebind - prop - rebind - specvar
(my-assert
(defun v4 (x) x)
v4)
(my-assert
(v4 55)
55)
(my-assert
(testvar 'v4)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil t nil nil nil nil nil nil))
;;; rebind
(my-assert
(fmakunbound 'v4)
v4)
(my-assert
(testvar 'v4)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil nil nil nil nil nil nil nil))
(my-assert
(defun v4 (x) (list x))
v4)
(my-assert
(v4 88)
(88))
(my-assert
(testvar 'v4)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil t nil nil nil nil nil nil))
(my-assert
(setf-get 'v4 'i1 11)
11)
(my-assert
(setf-get 'v4 'i2 22)
22)
(my-assert
(testvar 'v4)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil t nil nil t 11 22 nil))
;;; rebind
(my-assert
(fmakunbound 'v4)
v4)
(my-assert
(not (null (remprop 'v4 'i1)))
t)
(my-assert
(not (null (remprop 'v4 'i2)))
t)
(my-assert
(testvar 'v4)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil nil nil nil nil nil nil nil))
(my-assert
(defun v4 (x) (list x x x))
v4)
(my-assert
(v4 44)
(44 44 44))
(my-assert
(setf-get 'v4 'i2 222)
222)
(my-assert
(setf-get 'v4 'i3 333)
333)
(my-assert
(testvar 'v4)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil t nil nil t nil 222 333))
(my-assert
(defvar v4 'v4-value)
v4)
(my-assert
(testvar 'v4)
;; geb val konst svar func mac spec plist i1 i2 i3
(t v4-value nil t t nil nil t nil 222 333))
(my-assert
(clrvar 'v5)
v5)
;;;;; prop - rebind - con - rebind - fun
(my-assert
(setf-get 'v5 'i1 1)
1)
(my-assert
(setf-get 'v5 'i2 2)
2)
(my-assert
(testvar 'v5)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil nil nil nil t 1 2 nil))
;;; rebind
(my-assert
(not (null (remprop 'v5 'i1)))
t)
(my-assert
(not (null (remprop 'v5 'i2)))
t)
(my-assert
(testvar 'v5)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil nil nil nil nil nil nil nil))
(my-assert
(setf-get 'v5 'i1 11)
11)
(my-assert
(setf-get 'v5 'i2 22)
22)
(my-assert
(testvar 'v5)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil nil nil nil t 11 22 nil))
;;; con
(my-assert
(defconstant v5 '123)
v5)
(my-assert
(testvar 'v5)
;; geb val konst svar func mac spec plist i1 i2 i3
(t 123 t nil nil nil nil t 11 22 nil))
;;; rebind
(my-assert
(makunbound 'v5)
#+(or xcl allegro cmu sbcl) v5
#+(or clisp ecls) error)
(my-assert
(not (null (remprop 'v5 'i2)))
t)
(my-assert
(not (null (remprop 'v5 'i1)))
t)
#+xcl
(my-assert
(testvar 'v5)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil nil nil nil nil nil nil nil))
;;; das ging schief !!
(my-assert
(defconstant v5 321)
v5)
(my-assert
(setf-get 'v5 'i3 333)
333)
(my-assert
(setf-get 'v5 'i2 222)
222)
(my-assert
(testvar 'v5)
;; geb val konst svar func mac spec plist i1 i2 i3
(t 321 t nil nil nil nil t nil 222 333))
(my-assert
(defun v5 (x) x)
v5)
(my-assert
(v5 666)
666)
(my-assert
(testvar 'v5)
;; geb val konst svar func mac spec plist i1 i2 i3
(t 321 t nil t nil nil t nil 222 333))
(my-assert
(clrvar 'v6)
v6)
;;;;; prop mac con
(my-assert
(setf-get 'v6 'i1 1)
1)
(my-assert
(setf-get 'v6 'i3 3)
3)
(my-assert
(testvar 'v6)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil nil nil nil t 1 nil 3))
(my-assert
(defmacro v6 (x) (list 'quote x))
v6)
(my-assert
(v6 a)
a)
(my-assert
(testvar 'v6)
;; geb val konst svar func mac spec plist i1 i2 i3
(nil nil nil nil t t nil t 1 nil 3))
(my-assert
(defconstant v6 234)
v6)
(my-assert
(testvar 'v6)
;; geb val konst svar func mac spec plist i1 i2 i3
(t 234 t nil t t nil t 1 nil 3))
;; aufraeumen
(mapc #'unintern '(v1 v2 v3 v4 v5 v6))

21
src/ansi-tests/symbols.lisp Normal file
View file

@ -0,0 +1,21 @@
;;; based on v1.2 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(symbol-name (quote xyz))
"XYZ")
(my-assert
(let ((*gensym-counter* 32))
(gensym)
(prin1-to-string (gensym "FOO-")))
"#:FOO-33")
(my-assert
(let ((*gensym-counter* 32))
(gensym)
(prin1-to-string (gensym "garbage-")))
#+xcl "#:|garbage|-33"
#+(or clisp akcl allegro cmu sbcl ecls) "#:|garbage-33|"
#-(or xcl clisp akcl allegro cmu sbcl ecls) UNKNOWN)

509
src/ansi-tests/symboltest.lisp Normal file
View file

@ -0,0 +1,509 @@
;;; Peter Van Eynde, 1 March 2000 -*- mode: lisp -*-
(in-package :cl-user)
(defvar *the-cl-package* (find-package :common-lisp))
(my-assert
(packagep *the-cl-package*)
t)
(my-assert
(package-name *the-cl-package*)
"COMMON-LISP")
(my-assert
(not
(member "CL"
(package-nicknames *the-cl-package*)
:test #'string-equal))
NIL)
(defvar *allowed-exported-symbols*
'("&allow-other-keys" "*print-miser-width*"
"&aux" "*print-pprint-dispatch*"
"&body" "*print-pretty*"
"&environment" "*print-radix*"
"&key" "*print-readably*"
"&optional" "*print-right-margin*"
"&rest" "*query-io*"
"&whole" "*random-state*"
"*" "*read-base*"
"**" "*read-default-float-format*"
"***" "*read-eval*"
"*break-on-signals*" "*read-suppress*"
"*compile-file-pathname*" "*readtable*"
"*compile-file-truename*" "*standard-input*"
"*compile-print*" "*standard-output*"
"*compile-verbose*" "*terminal-io*"
"*debug-io*" "*trace-output*"
"*debugger-hook*" "+"
"*default-pathname-defaults*" "++"
"*error-output*" "+++"
"*features*" "-"
"*gensym-counter*" "/"
"*load-pathname*" "//"
"*load-print*" "///"
"*load-truename*" "/="
"*load-verbose*" "1+"
"*macroexpand-hook*" "1-"
"*modules*" "<"
"*package*" "<="
"*print-array*" "="
"*print-base*" ">"
"*print-case*" ">="
"*print-circle*" "abort"
"*print-escape*" "abs"
"*print-gensym*" "acons"
"*print-length*" "acos"
"*print-level*" "acosh"
"*print-lines*" "add-method"
"adjoin" "atom" "boundp"
"adjust-array" "base-char" "break"
"adjustable-array-p" "base-string" "broadcast-stream"
"allocate-instance" "bignum" "broadcast-stream-streams"
"alpha-char-p" "bit" "built-in-class"
"alphanumericp" "bit-and" "butlast"
"and" "bit-andc1" "byte"
"append" "bit-andc2" "byte-position"
"apply" "bit-eqv" "byte-size"
"apropos" "bit-ior" "caaaar"
"apropos-list" "bit-nand" "caaadr"
"aref" "bit-nor" "caaar"
"arithmetic-error" "bit-not" "caadar"
"arithmetic-error-operands" "bit-orc1" "caaddr"
"arithmetic-error-operation" "bit-orc2" "caadr"
"array" "bit-vector" "caar"
"array-dimension" "bit-vector-p" "cadaar"
"array-dimension-limit" "bit-xor" "cadadr"
"array-dimensions" "block" "cadar"
"array-displacement" "boole" "caddar"
"array-element-type" "boole-1" "cadddr"
"array-has-fill-pointer-p" "boole-2" "caddr"
"array-in-bounds-p" "boole-and" "cadr"
"array-rank" "boole-andc1" "call-arguments-limit"
"array-rank-limit" "boole-andc2" "call-method"
"array-row-major-index" "boole-c1" "call-next-method"
"array-total-size" "boole-c2" "car"
"array-total-size-limit" "boole-clr" "case"
"arrayp" "boole-eqv" "catch"
"ash" "boole-ior" "ccase"
"asin" "boole-nand" "cdaaar"
"asinh" "boole-nor" "cdaadr"
"assert" "boole-orc1" "cdaar"
"assoc" "boole-orc2" "cdadar"
"assoc-if" "boole-set" "cdaddr"
"assoc-if-not" "boole-xor" "cdadr"
"atan" "boolean" "cdar"
"atanh" "both-case-p" "cddaar"
"cddadr" "clear-input" "copy-tree"
"cddar" "clear-output" "cos"
"cdddar" "close" "cosh"
"cddddr" "clrhash" "count"
"cdddr" "code-char" "count-if"
"cddr" "coerce" "count-if-not"
"cdr" "compilation-speed" "ctypecase"
"ceiling" "compile" "debug"
"cell-error" "compile-file" "decf"
"cell-error-name" "compile-file-pathname" "declaim"
"cerror" "compiled-function" "declaration"
"change-class" "compiled-function-p" "declare"
"char" "compiler-macro" "decode-float"
"char-code" "compiler-macro-function" "decode-universal-time"
"char-code-limit" "complement" "defclass"
"char-downcase" "complex" "defconstant"
"char-equal" "complexp" "defgeneric"
"char-greaterp" "compute-applicable-methods" "define-compiler-macro"
"char-int" "compute-restarts" "define-condition"
"char-lessp" "concatenate" "define-method-combination"
"char-name" "concatenated-stream" "define-modify-macro"
"char-not-equal" "concatenated-stream-streams" "define-setf-expander"
"char-not-greaterp" "cond" "define-symbol-macro"
"char-not-lessp" "condition" "defmacro"
"char-upcase" "conjugate" "defmethod"
"char/=" "cons" "defpackage"
"char<" "consp" "defparameter"
"char<=" "constantly" "defsetf"
"char=" "constantp" "defstruct"
"char>" "continue" "deftype"
"char>=" "control-error" "defun"
"character" "copy-alist" "defvar"
"characterp" "copy-list" "delete"
"check-type" "copy-pprint-dispatch" "delete-duplicates"
"cis" "copy-readtable" "delete-file"
"class" "copy-seq" "delete-if"
"class-name" "copy-structure" "delete-if-not"
"class-of" "copy-symbol" "delete-package"
"denominator" "eq"
"deposit-field" "eql"
"describe" "equal"
"describe-object" "equalp"
"destructuring-bind" "error"
"digit-char" "etypecase"
"digit-char-p" "eval"
"directory" "eval-when"
"directory-namestring" "evenp"
"disassemble" "every"
"division-by-zero" "exp"
"do" "export"
"do*" "expt"
"do-all-symbols" "extended-char"
"do-external-symbols" "fboundp"
"do-symbols" "fceiling"
"documentation" "fdefinition"
"dolist" "ffloor"
"dotimes" "fifth"
"double-float" "file-author"
"double-float-epsilon" "file-error"
"double-float-negative-epsilon" "file-error-pathname"
"dpb" "file-length"
"dribble" "file-namestring"
"dynamic-extent" "file-position"
"ecase" "file-stream"
"echo-stream" "file-string-length"
"echo-stream-input-stream" "file-write-date"
"echo-stream-output-stream" "fill"
"ed" "fill-pointer"
"eighth" "find"
"elt" "find-all-symbols"
"encode-universal-time" "find-class"
"end-of-file" "find-if"
"endp" "find-if-not"
"enough-namestring" "find-method"
"ensure-directories-exist" "find-package"
"ensure-generic-function" "find-restart"
"find-symbol" "get-internal-run-time"
"finish-output" "get-macro-character"
"first" "get-output-stream-string"
"fixnum" "get-properties"
"flet" "get-setf-expansion"
"float" "get-universal-time"
"float-digits" "getf"
"float-precision" "gethash"
"float-radix" "go"
"float-sign" "graphic-char-p"
"floating-point-inexact" "handler-bind"
"floating-point-invalid-operation" "handler-case"
"floating-point-overflow" "hash-table"
"floating-point-underflow" "hash-table-count"
"floatp" "hash-table-p"
"floor" "hash-table-rehash-size"
"fmakunbound" "hash-table-rehash-threshold"
"force-output" "hash-table-size"
"format" "hash-table-test"
"formatter" "host-namestring"
"fourth" "identity"
"fresh-line" "if"
"fround" "ignorable"
"ftruncate" "ignore"
"ftype" "ignore-errors"
"funcall" "imagpart"
"function" "import"
"function-keywords" "in-package"
"function-lambda-expression" "incf"
"functionp" "initialize-instance"
"gcd" "inline"
"generic-function" "input-stream-p"
"gensym" "inspect"
"gentemp" "integer"
"get" "integer-decode-float"
"get-decoded-time" "integer-length"
"get-dispatch-macro-character" "integerp"
"get-internal-real-time" "interactive-stream-p"
"intern" "lisp-implementation-type"
"internal-time-units-per-second" "lisp-implementation-version"
"intersection" "list"
"invalid-method-error" "list*"
"invoke-debugger" "list-all-packages"
"invoke-restart" "list-length"
"invoke-restart-interactively" "listen"
"isqrt" "listp"
"keyword" "load"
"keywordp" "load-logical-pathname-translations"
"labels" "load-time-value"
"lambda" "locally"
"lambda-list-keywords" "log"
"lambda-parameters-limit" "logand"
"last" "logandc1"
"lcm" "logandc2"
"ldb" "logbitp"
"ldb-test" "logcount"
"ldiff" "logeqv"
"least-negative-double-float" "logical-pathname"
"least-negative-long-float" "logical-pathname-translations"
"least-negative-normalized-double-float" "logior"
"least-negative-normalized-long-float" "lognand"
"least-negative-normalized-short-float" "lognor"
"least-negative-normalized-single-float" "lognot"
"least-negative-short-float" "logorc1"
"least-negative-single-float" "logorc2"
"least-positive-double-float" "logtest"
"least-positive-long-float" "logxor"
"least-positive-normalized-double-float" "long-float"
"least-positive-normalized-long-float" "long-float-epsilon"
"least-positive-normalized-short-float" "long-float-negative-epsilon"
"least-positive-normalized-single-float" "long-site-name"
"least-positive-short-float" "loop"
"least-positive-single-float" "loop-finish"
"length" "lower-case-p"
"let" "machine-instance"
"let*" "machine-type"
"machine-version" "mask-field"
"macro-function" "max"
"macroexpand" "member"
"macroexpand-1" "member-if"
"macrolet" "member-if-not"
"make-array" "merge"
"make-broadcast-stream" "merge-pathnames"
"make-concatenated-stream" "method"
"make-condition" "method-combination"
"make-dispatch-macro-character" "method-combination-error"
"make-echo-stream" "method-qualifiers"
"make-hash-table" "min"
"make-instance" "minusp"
"make-instances-obsolete" "mismatch"
"make-list" "mod"
"make-load-form" "most-negative-double-float"
"make-load-form-saving-slots" "most-negative-fixnum"
"make-method" "most-negative-long-float"
"make-package" "most-negative-short-float"
"make-pathname" "most-negative-single-float"
"make-random-state" "most-positive-double-float"
"make-sequence" "most-positive-fixnum"
"make-string" "most-positive-long-float"
"make-string-input-stream" "most-positive-short-float"
"make-string-output-stream" "most-positive-single-float"
"make-symbol" "muffle-warning"
"make-synonym-stream" "multiple-value-bind"
"make-two-way-stream" "multiple-value-call"
"makunbound" "multiple-value-list"
"map" "multiple-value-prog1"
"map-into" "multiple-value-setq"
"mapc" "multiple-values-limit"
"mapcan" "name-char"
"mapcar" "namestring"
"mapcon" "nbutlast"
"maphash" "nconc"
"mapl" "next-method-p"
"maplist" "nil"
"nintersection" "package-error"
"ninth" "package-error-package"
"no-applicable-method" "package-name"
"no-next-method" "package-nicknames"
"not" "package-shadowing-symbols"
"notany" "package-use-list"
"notevery" "package-used-by-list"
"notinline" "packagep"
"nreconc" "pairlis"
"nreverse" "parse-error"
"nset-difference" "parse-integer"
"nset-exclusive-or" "parse-namestring"
"nstring-capitalize" "pathname"
"nstring-downcase" "pathname-device"
"nstring-upcase" "pathname-directory"
"nsublis" "pathname-host"
"nsubst" "pathname-match-p"
"nsubst-if" "pathname-name"
"nsubst-if-not" "pathname-type"
"nsubstitute" "pathname-version"
"nsubstitute-if" "pathnamep"
"nsubstitute-if-not" "peek-char"
"nth" "phase"
"nth-value" "pi"
"nthcdr" "plusp"
"null" "pop"
"number" "position"
"numberp" "position-if"
"numerator" "position-if-not"
"nunion" "pprint"
"oddp" "pprint-dispatch"
"open" "pprint-exit-if-list-exhausted"
"open-stream-p" "pprint-fill"
"optimize" "pprint-indent"
"or" "pprint-linear"
"otherwise" "pprint-logical-block"
"output-stream-p" "pprint-newline"
"package" "pprint-pop"
"pprint-tab" "read-char"
"pprint-tabular" "read-char-no-hang"
"prin1" "read-delimited-list"
"prin1-to-string" "read-from-string"
"princ" "read-line"
"princ-to-string" "read-preserving-whitespace"
"print" "read-sequence"
"print-not-readable" "reader-error"
"print-not-readable-object" "readtable"
"print-object" "readtable-case"
"print-unreadable-object" "readtablep"
"probe-file" "real"
"proclaim" "realp"
"prog" "realpart"
"prog*" "reduce"
"prog1" "reinitialize-instance"
"prog2" "rem"
"progn" "remf"
"program-error" "remhash"
"progv" "remove"
"provide" "remove-duplicates"
"psetf" "remove-if"
"psetq" "remove-if-not"
"push" "remove-method"
"pushnew" "remprop"
"quote" "rename-file"
"random" "rename-package"
"random-state" "replace"
"random-state-p" "require"
"rassoc" "rest"
"rassoc-if" "restart"
"rassoc-if-not" "restart-bind"
"ratio" "restart-case"
"rational" "restart-name"
"rationalize" "return"
"rationalp" "return-from"
"read" "revappend"
"read-byte" "reverse"
"room" "simple-bit-vector"
"rotatef" "simple-bit-vector-p"
"round" "simple-condition"
"row-major-aref" "simple-condition-format-arguments"
"rplaca" "simple-condition-format-control"
"rplacd" "simple-error"
"safety" "simple-string"
"satisfies" "simple-string-p"
"sbit" "simple-type-error"
"scale-float" "simple-vector"
"schar" "simple-vector-p"
"search" "simple-warning"
"second" "sin"
"sequence" "single-float"
"serious-condition" "single-float-epsilon"
"set" "single-float-negative-epsilon"
"set-difference" "sinh"
"set-dispatch-macro-character" "sixth"
"set-exclusive-or" "sleep"
"set-macro-character" "slot-boundp"
"set-pprint-dispatch" "slot-exists-p"
"set-syntax-from-char" "slot-makunbound"
"setf" "slot-missing"
"setq" "slot-unbound"
"seventh" "slot-value"
"shadow" "software-type"
"shadowing-import" "software-version"
"shared-initialize" "some"
"shiftf" "sort"
"short-float" "space"
"short-float-epsilon" "special"
"short-float-negative-epsilon" "special-operator-p"
"short-site-name" "speed"
"signal" "sqrt"
"signed-byte" "stable-sort"
"signum" "standard"
"simple-array" "standard-char"
"simple-base-string" "standard-char-p"
"standard-class" "sublis"
"standard-generic-function" "subseq"
"standard-method" "subsetp"
"standard-object" "subst"
"step" "subst-if"
"storage-condition" "subst-if-not"
"store-value" "substitute"
"stream" "substitute-if"
"stream-element-type" "substitute-if-not"
"stream-error" "subtypep"
"stream-error-stream" "svref"
"stream-external-format" "sxhash"
"streamp" "symbol"
"string" "symbol-function"
"string-capitalize" "symbol-macrolet"
"string-downcase" "symbol-name"
"string-equal" "symbol-package"
"string-greaterp" "symbol-plist"
"string-left-trim" "symbol-value"
"string-lessp" "symbolp"
"string-not-equal" "synonym-stream"
"string-not-greaterp" "synonym-stream-symbol"
"string-not-lessp" "t"
"string-right-trim" "tagbody"
"string-stream" "tailp"
"string-trim" "tan"
"string-upcase" "tanh"
"string/=" "tenth"
"string<" "terpri"
"string<=" "the"
"string=" "third"
"string>" "throw"
"string>=" "time"
"stringp" "trace"
"structure" "translate-logical-pathname"
"structure-class" "translate-pathname"
"structure-object" "tree-equal"
"style-warning" "truename"
"truncate" "values-list"
"two-way-stream" "variable"
"two-way-stream-input-stream" "vector"
"two-way-stream-output-stream" "vector-pop"
"type" "vector-push"
"type-error" "vector-push-extend"
"type-error-datum" "vectorp"
"type-error-expected-type" "warn"
"type-of" "warning"
"typecase" "when"
"typep" "wild-pathname-p"
"unbound-slot" "with-accessors"
"unbound-slot-instance" "with-compilation-unit"
"unbound-variable" "with-condition-restarts"
"undefined-function" "with-hash-table-iterator"
"unexport" "with-input-from-string"
"unintern" "with-open-file"
"union" "with-open-stream"
"unless" "with-output-to-string"
"unread-char" "with-package-iterator"
"unsigned-byte" "with-simple-restart"
"untrace" "with-slots"
"unuse-package" "with-standard-io-syntax"
"unwind-protect" "write"
"update-instance-for-different-class" "write-byte"
"update-instance-for-redefined-class" "write-char"
"upgraded-array-element-type" "write-line"
"upgraded-complex-part-type" "write-sequence"
"upper-case-p" "write-string"
"use-package" "write-to-string"
"use-value" "y-or-n-p"
"user-homedir-pathname" "yes-or-no-p"
"values" "zerop"))
;; test there aren't any symbols too much
(my-assert
(set-difference
(loop for symbol being
the external-symbol
of *the-cl-package*
collect symbol)
*allowed-exported-symbols*
:test #'string-equal)
nil
"This is the list of symbols that are exported but should not be exported
from the :cl package")
;; test there aren't any symbols missing
(my-assert
(set-difference
*allowed-exported-symbols*
(loop for symbol being
the external-symbol
of *the-cl-package*
collect symbol)
:test #'string-equal)
nil
"This is the list of symbols that are missing or not exported
from the :cl package")
(makunbound '*allowed-exported-symbols*)
(unintern '*allowed-exported-symbols*)

228
src/ansi-tests/tests.lisp Normal file
View file

@ -0,0 +1,228 @@
;; Test-Suiten ablaufen lassen: -*- mode: lisp -*-
(in-package :user)
(declaim (optimize (speed 0)
(safety 3)
(debug 3)))
(defmacro with-ignored-errors (&rest forms)
"This macro will evaluate the forms and return
the returnvalues or the type of the condition used."
(let ((tag (gensym)))
`(block ,tag
(handler-bind
((serious-condition
#'(lambda (condition)
(return-from ,tag
(values :ERROR
condition)))))
,@forms))))
(defvar *log* nil)
(defvar *output-generated* nil)
(defvar *lisp-type*
#+ecls "ECLS"
#+CLISP "CLISP"
#+AKCL "AKCL"
#+CMU "CMUCL"
#+sbcl "SBCL")
(defun check-and-puke (mode form result my-result condition why)
(flet ((safe-format (stream string &rest args)
(unless (ignore-errors
(progn
(apply #'format stream string args)
t))
(format stream "~&~%format of ~S failed!"
string))))
(cond
((eql result my-result)
(safe-format t "~%EQL-OK: ~S" my-result))
((equal result my-result)
(safe-format t "~%EQUAL-OK: ~S" my-result))
((equalp result my-result)
(safe-format t "~%EQUALP-OK: ~S" my-result))
((eq my-result :ERROR)
(cond
((ignore-errors
(typep condition result))
(safe-format t "~%TYPEP-OK, is of the expected error :~S"
result))
(t
(safe-format
t
"~&~%ERROR!! Got an error ~S (~A) I expected a instance of ~S~%"
condition condition
result)
(safe-format
t
"~%Form: ~S~%Should be an error of type: ~S~%~A: ~S (~A)~%Why: ~S~%"
form result *lisp-type*
condition condition
why)
(setf *output-generated* t)
(safe-format
*log*
"~&~%~A Form: ~S~%Should be an error of type: ~S~%~A: ~S (~A) ~%Why: ~S~%"
mode form result *lisp-type*
condition condition
why))))
(t
(safe-format t
"~&~%ERROR!! Got ~S solution ~S expected!"
my-result result)
(safe-format t
"~%~A Form: ~S~%Should be: ~S~%~A: ~S~%Why: ~S~%"
mode form result *lisp-type*
my-result why)
(setf *output-generated* t)
(safe-format *log*
"~&~%~A Form: ~S~%Should be: ~S~%~A: ~S~%Why : ~S~%"
mode form result *lisp-type*
my-result why)))))
(defmacro my-assert (form result &optional (why ""))
`(progn
(format t "~&~%testing : ~S~%"
',form)
;;; first we check if it work in interpreted mode
(multiple-value-bind (my-result condition)
(with-ignored-errors
(eval ',form))
(check-and-puke "interpreted"
',form ',result
my-result condition
,why))
(force-output)
;;; now we try to compile...
#+nil ; HACK
(multiple-value-bind (my-result condition)
(with-ignored-errors
(multiple-value-bind (function warnings-p failure-p)
(compile nil
#'(lambda ()
,form))
(format t "~&compiled ~S ~S ~S"
function warnings-p failure-p)
(multiple-value-bind (my-result condition)
(with-ignored-errors
(funcall function))
(check-and-puke "compiled"
',form ',result
my-result condition
,why))))
(when (eq my-result :error)
(check-and-puke "while compiling"
',form ',result
my-result condition
,why)))))
(defun run-test (testname &optional (source-path nil))
(let ((*package* *package*)
(*print-pretty* nil)
(*print-circle* nil)
;; to make the system quiet:
#+(or cmu sbcl)
(*gc-verbose* nil)
#+(or cmu sbcl)
(*compile-verbose* nil)
#+(or cmu sbcl)
(*compile-print* nil)
#+(or cmu sbcl)
(*compile-progress* nil)
#+(or cmu sbcl)
(*TOP-LEVEL-AUTO-DECLARE* nil)
(err-file (merge-pathnames testname "foo.erg"))
(source-file (merge-pathnames testname "foo.lisp")))
(when source-path
(setq source-file (merge-pathnames source-file source-path)))
(with-open-file (*log* err-file :direction :output)
(setf *output-generated* nil)
(load source-file)
(force-output *log*))
(unless *output-generated*
(delete-file err-file)))
(values))
(defun run-all-tests (&optional source-path)
(mapc #'(lambda (x) (print x) (run-test x source-path))
'(
"symboltest"
#-akcl "alltest"
"array"
"backquot"
#-akcl "characters"
#+(or CLISP ALLEGRO CMU SBCL)"clos"
#-ECLS
"cmucl-bugs"
#+(or CLISP ALLEGRO CMU SBCL ECLS) "conditions"
"eval20"
#-ecls
"excepsit"
"format"
#+xcl "hash"
"hashlong"
"iofkts"
"lambda"
"lists151"
"lists152"
"lists153"
"lists154"
"lists155"
"lists156"
#+(or CLISP ALLEGRO CMU SBCL) "loop"
"macro8"
"map"
#+(or CLISP ALLEGRO CMU SBCL) "mop"
"new-bugs"
#-(or cmu sbcl ecls) "number"
#+clisp "number2"
#+(or XCL CLISP) "path"
#+xcl "readtable"
"section10"
"section11"
"section12"
"section13"
"section14"
"section15"
"section16"
"section17"
#-ecls
"section18-errors"
"section18"
"section19"
"section2"
"section20"
"section21"
"section22"
"section3"
"section4"
"section5"
"section6"
"section7"
"section8"
"section9"
"setf"
"steele7"
#-allegro "streams"
"streamslong"
"strings"
#-akcl "symbol10"
"symbols"
"type"
#+(or sbcl cmu)
"unix-tests"
))
t)
;(run-test "unix-tests")
;(run-test "steele7")
;(quit)
;(run-all-tests)
;(format t "~%~%alles ok...~%")
;(quit)

516
src/ansi-tests/type.lisp Normal file
View file

@ -0,0 +1,516 @@
;;; based on v1.3 -*- mode: lisp -*-
(in-package :cl-user)
(my-assert
(typep (quote a) (quote symbol))
t)
(my-assert
(typep (quote nil) (quote symbol))
t)
(my-assert
(typep (quote (nil)) (quote symbol))
nil)
(my-assert
(typep 3 (quote integer))
t)
(my-assert
(typep 3 (quote (integer 0 4)))
t)
(my-assert
(typep 3 (quote (integer 0 3)))
t)
(my-assert
(typep 3 (quote (integer 0 2)))
nil)
(my-assert
(typep 3 (quote (float 0.0 2.0)))
nil)
(my-assert
(typep 3 (quote (float 0.0 2.0)))
nil)
(my-assert
(typep 3 (quote (float 0.0 4.0)))
nil)
(my-assert
(typep 3.2 (quote (float 0.0 4.0)))
t)
(my-assert
(typep 3.2 (quote (float 0.0 3.2)))
t)
(my-assert
(typep 3.2 (quote (float 0.0 (3.2))))
nil)
(my-assert
(typep 3.2 (quote (short-float 0.0s0 3.2s0)))
#+(or allegro cmu sbcl) t
#-(or allegro cmu sbcl) nil)
(my-assert
(typep 3.2 (quote (single-float 0.0f0 3.2f0)))
t)
(my-assert
(typep 3.2 (quote (double-float 0.0d0 3.2d0)))
nil)
(my-assert
(typep 3.2 (quote (double-float 0.0d0 3.2d0)))
nil)
(my-assert
(typep 3.2 (quote (double-float 0.0d0 3.2d0)))
nil)
(my-assert
(typep 3.2s0 (quote (double-float 0.0d0 3.2d0)))
nil)
(my-assert
(typep 3.2 (quote (double-float 0.0d0 3.2d0)))
nil)
(my-assert
(typep 3.2 (quote (float 0.0 3.2)))
t)
(my-assert
(typep 3.2s0 (quote (float 0.0s0 3.2s0)))
t)
(my-assert
(typep 2.0s0 (quote (short-float 0.0s0 3.0s0)))
t)
(my-assert
(typep 2.0s0 (quote (single-float 0.0f0 3.0f0)))
#+(or allegro cmu sbcl) t
#-(or allegro cmu sbcl) nil)
(my-assert
(typep 2.0 (quote (single-float 0.0f0 3.0f0)))
t)
(my-assert
(typep 2.0d0 (quote (double-float 0.0d0 3.0d0)))
t)
(my-assert
(typep 3.0d0 (quote (double-float 0.0d0 3.0d0)))
t)
(my-assert
(typep 3.0d0 (quote (double-float 0.0d0 (3.0d0))))
nil)
(my-assert
(typep 4 (quote (mod 4)))
nil)
(my-assert
(typep 4 (quote (mod 5)))
t)
(my-assert
(typep 4 (quote (rational 2 5)))
t)
(my-assert
(typep 4 (quote (rational 2 7/2)))
nil)
(my-assert
(typep 4 (quote (rational 2 9/2)))
t)
(my-assert
(typep 4 (quote (rational 2 4)))
t)
(my-assert
(typep 4/3 (quote (rational 2 4)))
nil)
(my-assert
(typep 2 (quote (rational 2 4)))
t)
(my-assert
(typep "abcd" (quote string))
t)
(my-assert
(typep "abcd" (quote (string 4)))
t)
(my-assert
(typep "abcd" (quote (string 43)))
nil)
(my-assert
(typep '#(2 3) (quote (complex integer)))
nil)
(my-assert
(typep '#(2 3) (quote complex))
nil)
(my-assert
(typep #c(2 3) (quote complex))
t)
(my-assert
(typep #c(2 3) (quote (complex integer)))
t)
(my-assert
(typep #c(2 3) (quote (complex float)))
nil)
(my-assert
(typep #c(2 3) (quote (complex symbol)))
#+(or cmu sbcl) error
#-(or cmu sbcl) nil)
(my-assert
(typep '#(a b c d) (quote vector))
t)
(my-assert
(typep '#(a b c d) (quote (vector * 4)))
t)
#|
;;
;; hängt von (upgraded-array-element-type 'symbol) ab!
(typep '#(a b c d) (quote (vector symbol 4)))
nil
|#
(my-assert
(typep (quote a) (quote (symbol cons)))
error)
(my-assert
(typep (quote a) (quote (or cons symbol)))
t)
(my-assert
(typep (quote a) (quote (or cons number)))
nil)
(my-assert
(typep (quote a) (quote (or atom number)))
t)
(my-assert
(typep (quote a) (quote (and atom number)))
nil)
(my-assert
(typep (quote 2) (quote (and atom number)))
t)
(my-assert
(typep (quote 2) (quote (member 1 2 3)))
t)
(my-assert
(typep (quote 2) (quote (member 1 3)))
nil)
(my-assert
(typep (quote 2) (quote (not (member 1 3))))
t)
(my-assert
(typep (quote 2) (quote (not (member 1 2 3))))
nil)
(my-assert
(typep 2 (quote (and number (not symbol))))
t)
(my-assert
(typep 2 (quote (and string (not symbol))))
nil)
(my-assert
(typep 2 (quote (or string (not symbol))))
t)
(my-assert
(typep (quote cons) (quote function))
nil)
(my-assert
(typep (quote cons) (quote (satisfies functionp)))
nil)
(my-assert
(typep (quote cons) (quote (satisfies not)))
nil)
(my-assert
(typep (quote nil) (quote (satisfies not)))
t)
(my-assert
(typep (quote nil) nil)
nil)
(my-assert
(typep (quote t) nil)
nil)
(my-assert
(subtypep (quote cons) t)
t)
(my-assert
(subtypep nil (quote cons))
t)
(my-assert
(subtypep (quote cons) (quote list))
t)
(my-assert
(subtypep (quote cons) (quote (or atom cons)))
t)
(my-assert
(subtypep (quote cons) (quote (and atom cons)))
nil)
(my-assert
(subtypep (quote cons) (quote (not atom)))
#-(or clisp akcl allegro) t
#+(or clisp akcl allegro) nil
"Type atom: is equivalent to (not cons)")
(my-assert
(subtypep (quote list) (quote (not atom)))
nil)
(my-assert
(subtypep (quote (integer 1 5)) (quote (integer 0 7)))
t)
(my-assert
(subtypep (quote (integer 1 5)) (quote (integer 0 (5))))
nil)
(my-assert
(subtypep (quote (integer 1 5)) (quote (integer 0 5)))
t)
(my-assert
(subtypep (quote (integer 1 5)) (quote (mod 5)))
nil)
(my-assert
(subtypep (quote (integer 1 (5))) (quote (mod 5)))
t)
(my-assert
(subtypep '(or (integer 1 (5) float))
'(or float (mod 5)))
#+(or xcl clisp ecls) t
#+(or allegro cmu sbcl) error
#-(or xcl clisp allegro cmu sbcl ecls) unknown)
(my-assert
(subtypep '(or (integer 1 (5)) float)
'(or float (mod 5)))
t)
(my-assert
(subtypep '(and number (float 1.0 (5.0)))
'(or float (mod 5)))
t)
(my-assert
(subtypep '(and number (not (float 1.0 (5.0))))
'(or float (mod 5)))
nil)
(my-assert
(subtypep '(and float (not (float 1.0 (5.0))))
'(or float (mod 5)))
t
"a float that is not in [1-5[ is a subtype of float")
(my-assert
(subtypep '(and float (not (float 1.0 (5.0))))
'(or (float * 1.0) (float * 5.0)))
nil)
(my-assert
(subtypep '(satisfies consp)
'list)
nil)
(my-assert
(subtypep (quote simple-string) (quote array))
t)
(my-assert
(deftype mod1 (n) `(and number (float 0.0 (,n))))
mod1)
(my-assert
(typep 4.1 (quote (mod1 5.0)))
t)
(my-assert
(typep 4.1 (quote (mod1 4.1)))
nil)
(my-assert
(subtypep (quote (float 2.3 6.7)) (quote (mod1 6.8)))
t)
(my-assert
(subtypep (quote (float 2.3 6.7)) (quote (mod1 6.7)))
nil)
(my-assert
(defun beliebiger-test (a) (member a (quote (u i v x))))
beliebiger-test)
(my-assert
(not (null (typep (quote u) (quote (satisfies beliebiger-test)))))
t)
(my-assert
(typep (quote a) (quote (satisfies beliebiger-test)))
nil)
;; This looks like asking a bit _too_ much
;; of the type system [pve]
(my-assert
(subtypep (quote (member u i)) (quote (satisfies beliebiger-test)))
#-(or cmu sbcl) t
#+(or cmu sbcl) nil)
(my-assert
(subtypep (quote (or (member u i))) (quote (satisfies beliebiger-test)))
#-(or cmu sbcl) t
#+(or cmu sbcl) nil)
(my-assert
(subtypep (quote (or (member u i a))) (quote (satisfies beliebiger-test)))
nil)
(my-assert
(subtypep (quote (satisfies beliebiger-test))
(quote (member u i v x y)))
nil)
(my-assert
(deftype beliebiger-typ nil (quote (satisfies beliebiger-test)))
beliebiger-typ)
(my-assert
(not (null (typep (quote u) (quote beliebiger-typ))))
t)
(my-assert
(typep (quote a) (quote beliebiger-typ))
nil)
(my-assert
(subtypep (quote (member u i)) (quote beliebiger-typ))
#-(or cmu sbcl) t
#+(or cmu sbcl) nil)
(my-assert
(subtypep (quote beliebiger-typ) (quote (member u i v x y)))
nil)
(my-assert
(subtypep nil 'fixnum) t)
(my-assert
(subtypep 'short-float 'float ) t)
(my-assert
(subtypep 'single-float 'float ) t)
(my-assert
(subtypep 'double-float 'float ) t)
(my-assert
(subtypep 'long-float 'float ) t)
(my-assert
(subtypep 'null 'symbol) t)
(my-assert
(subtypep 'null 'list) t)
(my-assert
(subtypep 'cons 'list) t)
(my-assert
(subtypep 'string 'vector) t)
(my-assert
(subtypep 'bit-vector 'vector) t)
(my-assert
(subtypep 'vector 'array) t)
(my-assert
(subtypep 'simple-array 'array) t)
(my-assert
(subtypep 'simple-vector 'simple-array) t)
(my-assert
(subtypep 'simple-vector 'vector) t)
(my-assert
(subtypep 'simple-string 'simple-array) t)
(my-assert
(subtypep 'simple-bit-vector 'simple-array) t)
(my-assert
(subtypep 'simple-string 'string) t)
(my-assert
(subtypep 'simple-string 'vector) t)
(my-assert
(subtypep 'simple-string 'simple-vector) nil)
(my-assert
(subtypep 'simple-bit-vector 'bit-vector) t)
(my-assert
(subtypep 'bit-vector 'vector) t)
(my-assert
(subtypep 'simple-bit-vector 'simple-vector) nil)
(my-assert
(subtypep 'unsigned-byte 'integer) t)
(my-assert
(subtypep 'signed-byte 'integer) t)

52
src/ansi-tests/unix-tests.lisp Normal file
View file

@ -0,0 +1,52 @@
(in-package :cl-user)
(my-assert
(progn (ensure-directories-exist "test-dir/") t)
T)
(my-assert
(#+cmu unix:unix-access
#+sbcl sb-unix:unix-access "test-dir"
#+cmu unix:r_ok
#+sbcl sb-unix:r_ok)
T)
(my-assert
(#+cmu unix:unix-access #+sbcl sb-unix:unix-access "test-dir" #+cmu unix:w_ok #+sbcl sb-unix:w_ok)
T)
(my-assert
(#+cmu unix:unix-access #+sbcl sb-unix:unix-access "test-dir" #+cmu unix:x_ok #+sbcl sb-unix:x_ok)
T)
(my-assert
(#+cmu unix:unix-access #+sbcl sb-unix:unix-access "test-dir" #+cmu unix:f_ok #+sbcl sb-unix:f_ok)
T)
(with-open-file (file "test-dir/a"
:direction :output
:if-exists :supersede)
(princ "hello world" file))
(my-assert
(#+cmu unix:unix-access #+sbcl sb-unix:unix-access "test-dir/a" #+cmu unix:r_ok #+sbcl sb-unix:r_ok)
T)
(my-assert
(#+cmu unix:unix-access #+sbcl sb-unix:unix-access "test-dir/a" #+cmu unix:w_ok #+sbcl sb-unix:w_ok)
T)
(my-assert
(#+cmu unix:unix-access #+sbcl sb-unix:unix-access "test-dir/a" #+cmu unix:x_ok #+sbcl sb-unix:x_ok)
NIL)
(my-assert
(#+cmu unix:unix-access #+sbcl sb-unix:unix-access "test-dir/a" #+cmu unix:f_ok #+sbcl sb-unix:f_ok)
T)
(my-assert
(progn
(#+cmu unix:unix-gettimeofday #+sbcl sb-unix:unix-gettimeofday)
t)
t)

56
src/bare.lsp.in Normal file
View file

@ -0,0 +1,56 @@
;;;
;;; Configuration file for the bootstrapping version of ECLS
;;;
;;; * Set ourselves in the 'SYSTEM package
;;;
(setq *package* (find-package "SYSTEM"))
;;;
;;; * Load Common-Lisp base library
;;;
(load "lsp/load.lsp")
#ifdef CLOS
;;;
;;; * Load PCL-based Common-Lisp Object System
;;;
(setf sys::*gc-verbose* nil)
(load "clos/load.lsp")
#endif
;;;
;;; * Load the compiler.
;;;
(load "cmp/load.lsp")
;;;
;;; * By redefining *system-directory* ECLS will be able to
;;; find headers and libraries in the build directory.
;;;
(setq si::*system-directory* (namestring (sys::chdir "./")))
;;;
;;; * Add include path to not yet installed headers
;;;
(setq compiler::*cc-flags* (concatenate 'string compiler::*cc-flags* " -I@srcdir@/h -I@srcdir@/gmp "))
;;;
;;; * Beppe's defsystem utility
;;;
(load "@srcdir@/util/system.lsp")
;;;
;;; * We redefine this to force generation of source files
;;; in the object directory -- source files help debugging
;;; with GDB.
;;;
(defun sbt::sbt-compile-file (&rest s)
(apply #'compiler::compile-file
(car s)
:c-file t :h-file t :data-file t :system-p t
(cdr s)))
;;;
;;; * Go back to build directory to start compiling
;;;
(setq *features* (remove :ecls-min *features*))

131
src/c/Makefile.in Normal file
View file

@ -0,0 +1,131 @@
#
# Makefile for ECLS core library
#
top_srcdir= @top_srcdir@
srcdir = @srcdir@
VPATH = @srcdir@
MACHINE = @MACHINE@
# Programs used by "make":
#
CC = @CC@
DEFS = -D$(MACHINE)
CFLAGS = -c -I../h -I$(HDIR) -I$(top_srcdir)/gc @CFLAGS@ $(DEFS)
#ifndef HAVE_LOCAL_GMP
CFLAGS += -I$(top_srcdir)/gmp
#endif
SHELL = /bin/sh
RM = @RM@
#ifdef MSDOS
DPP = dpp.exe
#else
DPP = ./dpp
#endif
# Data for installation
#
INSTALL = @INSTALL@
INSTALL_DATA = @INSTALL_DATA@
libdir = @libdir@
# Files
HDIR = $(top_srcdir)/h
HFILES = ../h/config.h $(HDIR)/ecls.h $(HDIR)/ecls-cmp.h\
$(HDIR)/machines.h $(HDIR)/object.h $(HDIR)/cs.h $(HDIR)/stacks.h\
$(HDIR)/external.h $(HDIR)/lisp_external.h $(HDIR)/eval.h\
$(HDIR)/number.h $(HDIR)/page.h $(HDIR)/unify.h\
$(HDIR)/lwp.h $(HDIR)/critical.h
#ifdef GBC_BOEHM
ALLOC = alloc_2.o
#else
ALLOC = alloc.o gbc.o
#endif
OBJS = main.o $(ALLOC) symbol.o package.o list.o\
apply.o eval.o interpreter.o compiler.o disassembler.o \
lex.o reference.o character.o\
file.o read.o print.o error.o string.o cfun.o\
typespec.o assignment.o \
predicate.o big.o number.o\
num_pred.o num_comp.o num_arith.o num_sfun.o num_co.o\
num_log.o num_rand.o array.o sequence.o cmpaux.o\
macros.o backq.o stacks.o \
time.o unixint.o\
mapfun.o multival.o hash.o format.o pathname.o\
structure.o load.o unixfsys.o unixsys.o \
all_keywords.o all_symbols.o all_functions.o init.o
#ifdef THREADS
OBJS += lwp.o
#endif
#ifdef LOCATIVE
OBJS += unify.o
#endif
#if defined(TCP) || defined(CLX)
OBJS += tcp.o
#endif
#ifdef CLOS
OBJS += clos.o instance.o gfun.o
#endif
#ifdef TK
OBJS += tclBasic.o tkMain.o
#endif
#ifdef PROFILE
OBJS += profile.o
#endif
#ifdef MSDOS
OBJS += dostimes.o dosdummy.o
#endif
.SUFFIXES: .c .o .d
.c.o: $(HFILES)
$(CC) $(CFLAGS) -o $@ $<
.d.c: $(DPP) $(HFILES)
$(DPP) $< $@
all: $(DPP) ../libecls.a cinit.o
.PHONY: all
install: $(HFILES)
for i in $(HFILES); do $(INSTALL_DATA) $$i $(PREFIX)$(libdir)/h; done
../libecls.a: $(OBJS)
ar cr $@ $(OBJS)
ranlib $@
clean:
$(RM) *.c $(OBJS) ../libecls.a cinit.o core a.out
# Build rules
./dpp : $(srcdir)/dpp.c
$(CC) @CFLAGS@ -I$(HDIR) $(srcdir)/dpp.c -o $@
dpp.exe : $(srcdir)/dpp.c
make dpp
coff2exe dpp
$(RM) dpp
#
# Some files may break due to gcc optimizations
#
#apply.o: apply.c $(HFILES) $(HDIR)/cs.h
# dangerous to optimize due to assembler hack
# $(CC) $(CFLAGS) -O0 -g apply.c -o $@
#ifdef sgi
# gcc optimization causes trouble
assignment.o: assignment.c $(HFILES)
$(CC) $(CFLAGS) -g assignment.c -o $@
#else
# $(CC) $(CFLAGS) assignment.c -o $@
#endif
#ifdef sgi
# gcc optimization causes trouble
gbc.o: gbc.c $(HFILES)
$(CC) $(CFLAGS) -g gbc.c -o $@
#else
# $(CC) $(CFLAGS) gbc.c -o $@
#endif

889
src/c/all_functions.d Normal file
View file

@ -0,0 +1,889 @@
#define _ARGS(x) (int n, ...)
#include "ecls.h"
#include "page.h"
struct function_info {
const char *name;
cl_object (*f)(int, ...);
short type;
};
#define form 2
#define cl 0
#define si 1
static const struct function_info all_functions[] = {
/* alloc.c */
#if !defined(GBC_BOEHM)
{"ALLOCATE", siLallocate, si},
{"ALLOCATED-PAGES", siLallocated_pages, si},
{"MAXIMUM-ALLOCATABLE-PAGES", siLmaxpage, si},
{"ALLOCATE-CONTIGUOUS-PAGES", siLalloc_contpage, si},
{"ALLOCATED-CONTIGUOUS-PAGES", siLncbpage, si},
{"MAXIMUM-CONTIGUOUS-PAGES", siLmaxcbpage, si},
{"GET-HOLE-SIZE", siLget_hole_size, si},
{"SET-HOLE-SIZE", siLset_hole_size, si},
{"IGNORE-MAXIMUM-PAGES", siLignore_maximum_pages, si},
#endif /* !GBC_BOEHM */
/* alloc_2.c */
#ifdef GBC_BOEHM
{"GC", Lgc, cl},
#endif
/* array.c */
{"MAKE-PURE-ARRAY", siLmake_pure_array, si},
{"MAKE-VECTOR", siLmake_vector, si},
{"AREF", Laref, cl},
{"ASET", siLaset, si},
{"ARRAY-ELEMENT-TYPE", Larray_element_type, cl},
{"ARRAY-RANK", Larray_rank, cl},
{"ARRAY-DIMENSION", Larray_dimension, cl},
{"ARRAY-TOTAL-SIZE", Larray_total_size, cl},
{"ADJUSTABLE-ARRAY-P", Ladjustable_array_p, cl},
{"DISPLACED-ARRAY-P", siLdisplaced_array_p, si},
{"SVREF", Lsvref, cl},
{"SVSET", siLsvset, si},
{"ARRAY-HAS-FILL-POINTER-P", Larray_has_fill_pointer_p, cl},
{"FILL-POINTER", Lfill_pointer, cl},
{"FILL-POINTER-SET", siLfill_pointer_set, si},
{"REPLACE-ARRAY", siLreplace_array, si},
/* assignment.c */
{"CLEAR-COMPILER-PROPERTIES", siLclear_compiler_properties, si},
{"SETQ", NULL, form},
{"PSETQ", NULL, form},
{"SET", Lset, cl},
{"FSET", siLfset, si},
{"MULTIPLE-VALUE-SETQ", NULL, form},
{"MAKUNBOUND", Lmakunbound, cl},
{"FMAKUNBOUND", Lfmakunbound, cl},
#if 0
{"SETF", NULL, form},
{"PUSH", NULL, form},
{"POP", NULL, form},
{"INCF", NULL, form},
{"DECF", NULL, form},
#endif
{"SETF-NAMEP", siLsetf_namep, si},
/* block.c */
{"BLOCK", NULL, form},
{"RETURN-FROM", NULL, form},
{"RETURN", NULL, form},
/* catch.c */
{"CATCH", NULL, form},
{"UNWIND-PROTECT", NULL, form},
{"THROW", NULL, form},
/* cfun.c */
{"COMPILED-FUNCTION-NAME", siLcompiled_function_name, si},
{"COMPILED-FUNCTION-BLOCK", siLcompiled_function_block, si},
/* character.d */
{"STANDARD-CHAR-P", Lstandard_char_p, cl},
{"GRAPHIC-CHAR-P", Lgraphic_char_p, cl},
{"ALPHA-CHAR-P", Lalpha_char_p, cl},
{"UPPER-CASE-P", Lupper_case_p, cl},
{"LOWER-CASE-P", Llower_case_p, cl},
{"BOTH-CASE-P", Lboth_case_p, cl},
{"DIGIT-CHAR-P", Ldigit_char_p, cl},
{"ALPHANUMERICP", Lalphanumericp, cl},
{"CHAR=", Lchar_eq, cl},
{"CHAR/=", Lchar_neq, cl},
{"CHAR<", Lchar_l, cl},
{"CHAR>", Lchar_g, cl},
{"CHAR<=", Lchar_le, cl},
{"CHAR>=", Lchar_ge, cl},
{"CHAR-EQUAL", Lchar_equal, cl},
{"CHAR-NOT-EQUAL", Lchar_not_equal, cl},
{"CHAR-LESSP", Lchar_lessp, cl},
{"CHAR-GREATERP", Lchar_greaterp, cl},
{"CHAR-NOT-GREATERP", Lchar_not_greaterp, cl},
{"CHAR-NOT-LESSP", Lchar_not_lessp, cl},
{"CHARACTER", Lcharacter, cl},
{"CHAR-CODE", Lchar_code, cl},
{"CODE-CHAR", Lcode_char, cl},
{"CHAR-UPCASE", Lchar_upcase, cl},
{"CHAR-DOWNCASE", Lchar_downcase, cl},
{"DIGIT-CHAR", Ldigit_char, cl},
{"CHAR-INT", Lchar_int, cl},
{"INT-CHAR", Lint_char, cl},
{"CHAR-NAME", Lchar_name, cl},
{"NAME-CHAR", Lname_char, cl},
/* cmpaux.c */
{"SPECIALP", siLspecialp, si},
/* conditional.c */
{"IF", NULL, form},
{"COND", NULL, form},
{"CASE", NULL, form},
{"WHEN", NULL, form},
{"UNLESS", NULL, form},
/* disassembler.c */
{"BC-DISASSEMBLE", siLbc_disassemble, si},
{"BC-SPLIT", siLbc_split, si},
/* error.c */
#if defined(FRAME_CHAIN) && !defined(RUNTIME)
{"BT", siLbacktrace, si},
#endif
{"ERROR", Lerror, cl},
{"CERROR", Lcerror, cl},
{"UNIVERSAL-ERROR-HANDLER", siLuniversal_error_handler, si},
/* eval.c */
{"EVAL", Leval, cl},
{"EVALHOOK", Levalhook, cl},
{"APPLYHOOK", Lapplyhook, cl},
{"CONSTANTP", Lconstantp, cl},
{"UNLINK-SYMBOL", siLunlink_symbol, si},
{"APPLY", Lapply, cl},
{"FUNCALL", Lfuncall, cl},
/* file.d */
{"MAKE-SYNONYM-STREAM", Lmake_synonym_stream, cl},
{"MAKE-BROADCAST-STREAM", Lmake_broadcast_stream, cl},
{"MAKE-CONCATENATED-STREAM", Lmake_concatenated_stream, cl},
{"MAKE-TWO-WAY-STREAM", Lmake_two_way_stream, cl},
{"MAKE-ECHO-STREAM", Lmake_echo_stream, cl},
{"MAKE-STRING-INPUT-STREAM", Lmake_string_input_stream, cl},
{"MAKE-STRING-OUTPUT-STREAM", Lmake_string_output_stream, cl},
{"GET-OUTPUT-STREAM-STRING", Lget_output_stream_string, cl},
{"OUTPUT-STREAM-STRING", siLoutput_stream_string, si},
{"STREAMP", Lstreamp, cl},
{"INPUT-STREAM-P", Linput_stream_p, cl},
{"OUTPUT-STREAM-P", Loutput_stream_p, cl},
{"STREAM-ELEMENT-TYPE", Lstream_element_type, cl},
{"CLOSE", Lclose, cl},
{"OPEN", Lopen, cl},
{"FILE-POSITION", Lfile_position, cl},
{"FILE-LENGTH", Lfile_length, cl},
{"OPEN-STREAM-P", Lopen_stream_p, cl},
{"GET-STRING-INPUT-STREAM-INDEX", siLget_string_input_stream_index, si},
{"MAKE-STRING-OUTPUT-STREAM-FROM-STRING", siLmake_string_output_stream_from_string, si},
{"COPY-STREAM", siLcopy_stream, si},
/* format. c */
{"FORMAT", Lformat, cl},
/* gbc.c */
#if !defined(GBC_BOEHM)
{"ROOM-REPORT", siLroom_report, si},
{"RESET-GC-COUNT", siLreset_gc_count, si},
{"GC", Lgc, cl},
{"GC-TIME", siLgc_time, si},
#endif
/* gfun.c */
#ifdef CLOS
{"ALLOCATE-GFUN", siLallocate_gfun, si},
{"GFUN-NAME", siLgfun_name, si},
{"GFUN-NAME-SET", siLgfun_name_set, si},
{"GFUN-METHOD-HT", siLgfun_method_ht, si},
{"GFUN-METHOD-HT-SET", siLgfun_method_ht_set, si},
{"GFUN-SPEC-HOW-REF", siLgfun_spec_how_ref, si},
{"GFUN-SPEC-HOW-SET", siLgfun_spec_how_set, si},
{"GFUN-INSTANCE", siLgfun_instance, si},
{"GFUN-INSTANCE-SET", siLgfun_instance_set, si},
{"GFUNP", siLgfunp, si},
{"METHOD-HT-GET", siLmethod_ht_get, si},
{"SET-COMPILED-FUNCTION-NAME", siLset_compiled_function_name, si},
#endif CLOS
/* hash.d */
{"MAKE-HASH-TABLE", Lmake_hash_table, cl},
{"HASH-TABLE-P", Lhash_table_p, cl},
{"GETHASH", Lgethash, cl},
{"REMHASH", Lremhash, cl},
{"MAPHASH", Lmaphash, cl},
{"CLRHASH", Lclrhash, cl},
{"HASH-TABLE-COUNT", Lhash_table_count, cl},
{"SXHASH", Lsxhash, cl},
{"HASH-SET", siLhash_set, si},
{"HASH-TABLE-REHASH-SIZE", Lhash_table_rehash_size, cl},
{"HASH-TABLE-REHASH-THRESHOLD", Lhash_table_rehash_threshold, cl},
/* instance.c */
#ifdef CLOS
{"ALLOCATE-INSTANCE", siLallocate_instance, si},
{"CHANGE-INSTANCE", siLchange_instance, si},
{"INSTANCE-REF-SAFE", siLinstance_ref_safe, si},
{"INSTANCE-REF", siLinstance_ref, si},
{"INSTANCE-SET", siLinstance_set, si},
{"INSTANCE-CLASS", siLinstance_class, si},
{"INSTANCE-CLASS-SET", siLinstance_class_set, si},
{"INSTANCEP", siLinstancep, si},
{"SL-BOUNDP", siLsl_boundp, si},
{"SL-MAKUNBOUND", siLsl_makunbound, si},
#endif CLOS
/* interpreter.c */
{"INTERPRETER-STACK", siLinterpreter_stack, si},
{"MAKE-LAMBDA", siLmake_lambda, si},
/* iteration.c */
{"DO", NULL, form},
{"DO*", NULL, form},
{"DOLIST", NULL, form},
{"DOTIMES", NULL, form},
/* lex.c */
{"LEX-ENV", siLlex_env, si},
/* let.c */
{"LET", NULL, form},
{"LET*", NULL, form},
{"MULTIPLE-VALUE-BIND", NULL, form},
{"COMPILER-LET", NULL, form},
{"FLET", NULL, form},
{"LABELS", NULL, form},
{"MACROLET", NULL, form},
{"SYMBOL-MACROLET", NULL, form},
/* list.d */
{"CAR", Lcar, cl},
{"CDR", Lcdr, cl},
{"CAAR", Lcaar, cl},
{"CADR", Lcadr, cl},
{"CDAR", Lcdar, cl},
{"CDDR", Lcddr, cl},
{"CAAAR", Lcaaar, cl},
{"CAADR", Lcaadr, cl},
{"CADAR", Lcadar, cl},
{"CADDR", Lcaddr, cl},
{"CDAAR", Lcdaar, cl},
{"CDADR", Lcdadr, cl},
{"CDDAR", Lcddar, cl},
{"CDDDR", Lcdddr, cl},
{"CAAAAR", Lcaaaar, cl},
{"CAAADR", Lcaaadr, cl},
{"CAADAR", Lcaadar, cl},
{"CAADDR", Lcaaddr, cl},
{"CADAAR", Lcadaar, cl},
{"CADADR", Lcadadr, cl},
{"CADDAR", Lcaddar, cl},
{"CADDDR", Lcadddr, cl},
{"CDAAAR", Lcdaaar, cl},
{"CDAADR", Lcdaadr, cl},
{"CDADAR", Lcdadar, cl},
{"CDADDR", Lcdaddr, cl},
{"CDDAAR", Lcddaar, cl},
{"CDDADR", Lcddadr, cl},
{"CDDDAR", Lcdddar, cl},
{"CDDDDR", Lcddddr, cl},
{"CONS", Lcons, cl},
{"TREE-EQUAL", Ltree_equal, cl},
{"ENDP", Lendp, cl},
{"LIST-LENGTH", Llist_length, cl},
{"NTH", Lnth, cl},
{"FIRST", Lcar, cl},
{"SECOND", Lcadr, cl},
{"THIRD", Lcaddr, cl},
{"FOURTH", Lcadddr, cl},
{"FIFTH", Lfifth, cl},
{"SIXTH", Lsixth, cl},
{"SEVENTH", Lseventh, cl},
{"EIGHTH", Leighth, cl},
{"NINTH", Lninth, cl},
{"TENTH", Ltenth, cl},
{"REST", Lcdr, cl},
{"NTHCDR", Lnthcdr, cl},
{"LAST", Llast, cl},
{"LIST", Llist, cl},
{"LIST*", LlistA, cl},
{"MAKE-LIST", Lmake_list, cl},
{"APPEND", Lappend, cl},
{"COPY-LIST", Lcopy_list, cl},
{"COPY-ALIST", Lcopy_alist, cl},
{"COPY-TREE", Lcopy_tree, cl},
{"REVAPPEND", Lrevappend, cl},
{"NCONC", Lnconc, cl},
{"NRECONC", Lreconc, cl},
{"BUTLAST", Lbutlast, cl},
{"NBUTLAST", Lnbutlast, cl},
{"LDIFF", Lldiff, cl},
{"RPLACA", Lrplaca, cl},
{"RPLACD", Lrplacd, cl},
{"SUBST", Lsubst, cl},
{"SUBST-IF", Lsubst_if, cl},
{"SUBST-IF-NOT", Lsubst_if_not, cl},
{"NSUBST", Lnsubst, cl},
{"NSUBST-IF", Lnsubst_if, cl},
{"NSUBST-IF-NOT", Lnsubst_if_not, cl},
{"SUBLIS", Lsublis, cl},
{"NSUBLIS", Lnsublis, cl},
{"MEMBER", Lmember, cl},
{"MEMBER-IF", Lmember_if, cl},
{"MEMBER-IF-NOT", Lmember_if_not, cl},
{"MEMBER1", Lmember1, si},
{"TAILP", Ltailp, cl},
{"ADJOIN", Ladjoin, cl},
{"ACONS", Lacons, cl},
{"PAIRLIS", Lpairlis, cl},
{"ASSOC", Lassoc, cl},
{"ASSOC-IF", Lassoc_if, cl},
{"ASSOC-IF-NOT", Lassoc_if_not, cl},
{"RASSOC", Lrassoc, cl},
{"RASSOC-IF", Lrassoc_if, cl},
{"RASSOC-IF-NOT", Lrassoc_if_not, cl},
{"MEMQ", siLmemq, si},
/* load.d */
{"LOAD", Lload, cl},
{"LOAD-BINARY", siLload_binary, si},
{"LOAD-SOURCE", siLload_source, si},
#if 0
{"FASLINK", siLfaslink, si},
#endif
/* lwp.d */
#ifdef THREADS
{"THREAD-BREAK-IN", siLthread_break_in, si},
{"THREAD-BREAK-QUIT", siLthread_break_quit, si},
{"THREAD-BREAK-RESUME", siLthread_break_resume, si},
{"MAKE-THREAD", Lmake_thread, cl},
{"DEACTIVATE", Ldeactivate, cl},
{"REACTIVATE", Lreactivate, cl},
{"KILL-THREAD", Lkill_thread, cl},
{"CURRENT-THREAD", Lcurrent_thread, cl},
{"THREAD-STATUS", Lthread_status, cl},
{"THREAD-LIST", Lthread_list, cl},
{"MAKE-CONTINUATION", Lmake_continuation, cl},
{"THREAD-OF", Lthread_of, cl},
{"CONTINUATION-OF", Lcontinuation_of, cl},
{"RESUME", Lresume, cl},
{"%DISABLE-SCHEDULER", Ldisable_scheduler, cl},
{"%ENABLE-SCHEDULER", Lenable_scheduler, cl},
{"%SUSPEND", Lsuspend, cl},
{"%DELAY", Ldelay, cl},
{"%THREAD-WAIT", Lthread_wait, cl},
{"%THREAD-WAIT-WITH-TIMEOUT", Lthread_wait_with_timeout, cl},
#endif THREADS
/* macros.c */
{"MACROEXPAND", Lmacroexpand, cl},
{"MACROEXPAND-1", Lmacroexpand_1, cl},
/* main.c */
{"QUIT", Lquit, cl},
{"ARGC", siLargc, si},
{"ARGV", siLargv, si},
{"GETENV", siLgetenv, si},
{"POINTER", siLaddress, si},
#if !defined(MSDOS) && !defined(__NeXT)
{"MACHINE-INSTANCE", Lmachine_instance, cl},
{"MACHINE-VERSION", Lmachine_version, cl},
{"SOFTWARE-TYPE", Lsoftware_type, cl},
{"SOFTWARE-VERSION", Lsoftware_version, cl},
#endif MSDOS
/* mapfun.c */
{"MAPCAR", Lmapcar, cl},
{"MAPLIST", Lmaplist, cl},
{"MAPC", Lmapc, cl},
{"MAPL", Lmapl, cl},
{"MAPCAN", Lmapcan, cl},
{"MAPCON", Lmapcon, cl},
/* multival.c */
{"VALUES", Lvalues, cl},
{"VALUES-LIST", Lvalues_list, cl},
{"MULTIPLE-VALUE-CALL", NULL, form},
{"MULTIPLE-VALUE-PROG1", NULL, form},
{"MULTIPLE-VALUE-LIST", NULL, form},
{"NTH-VALUE", NULL, form},
/* num-arith.c */
{"+", Lplus, cl},
{"-", Lminus, cl},
{"*", Ltimes, cl},
{"/", Ldivide, cl},
{"1+", Lone_plus, cl},
{"1-", Lone_minus, cl},
{"CONJUGATE", Lconjugate, cl},
{"GCD", Lgcd, cl},
{"LCM", Llcm, cl},
/* num_co.c */
{"FLOAT", Lfloat, cl},
{"NUMERATOR", Lnumerator, cl},
{"DENOMINATOR", Ldenominator, cl},
{"FLOOR", Lfloor, cl},
{"CEILING", Lceiling, cl},
{"TRUNCATE", Ltruncate, cl},
{"ROUND", Lround, cl},
{"MOD", Lmod, cl},
{"REM", Lrem, cl},
{"DECODE-FLOAT", Ldecode_float, cl},
{"SCALE-FLOAT", Lscale_float, cl},
{"FLOAT-RADIX", Lfloat_radix, cl},
{"FLOAT-SIGN", Lfloat_sign, cl},
{"FLOAT-DIGITS", Lfloat_digits, cl},
{"FLOAT-PRECISION", Lfloat_precision, cl},
{"INTEGER-DECODE-FLOAT", Linteger_decode_float, cl},
{"COMPLEX", Lcomplex, cl},
{"REALPART", Lrealpart, cl},
{"IMAGPART", Limagpart, cl},
/* num_comp.c */
{"=", Lall_the_same, cl},
{"/=", Lall_different, cl},
{"<", Lmonotonically_increasing, cl},
{">", Lmonotonically_decreasing, cl},
{"<=", Lmonotonically_nondecreasing, cl},
{">=", Lmonotonically_nonincreasing, cl},
{"MAX", Lmax, cl},
{"MIN", Lmin, cl},
/* num_log.c */
{"LOGIOR", Llogior, cl},
{"LOGXOR", Llogxor, cl},
{"LOGAND", Llogand, cl},
{"LOGEQV", Llogeqv, cl},
{"BOOLE", Lboole, cl},
{"LOGBITP", Llogbitp, cl},
{"ASH", Lash, cl},
{"LOGCOUNT", Llogcount, cl},
{"INTEGER-LENGTH", Linteger_length, cl},
{"BIT-ARRAY-OP", siLbit_array_op, si},
/* num_pred.c */
{"ZEROP", Lzerop, cl},
{"PLUSP", Lplusp, cl},
{"MINUSP", Lminusp, cl},
{"ODDP", Loddp, cl},
{"EVENP", Levenp, cl},
{"NANI", siLnani, si},
/* num_rand.c */
{"RANDOM", Lrandom, cl},
{"MAKE-RANDOM-STATE", Lmake_random_state, cl},
{"RANDOM-STATE-P", Lrandom_state_p, cl},
/* num_sfun.c */
{"EXP", Lexp, cl},
{"EXPT", Lexpt, cl},
{"LOG", Llog, cl},
{"SQRT", Lsqrt, cl},
{"SIN", Lsin, cl},
{"COS", Lcos, cl},
{"TAN", Ltan, cl},
{"ATAN", Latan, cl},
{"SINH", Lsinh, cl},
{"COSH", Lcosh, cl},
{"TANH", Ltanh, cl},
/* package.d */
{"MAKE-PACKAGE", Lmake_package, cl},
{"SELECT-PACKAGE", siLselect_package, si},
{"FIND-PACKAGE", Lfind_package, cl},
{"PACKAGE-NAME", Lpackage_name, cl},
{"PACKAGE-NICKNAMES", Lpackage_nicknames, cl},
{"RENAME-PACKAGE", Lrename_package, cl},
{"PACKAGE-USE-LIST", Lpackage_use_list, cl},
{"PACKAGE-USED-BY-LIST", Lpackage_used_by_list, cl},
{"PACKAGE-SHADOWING-SYMBOLS", Lpackage_shadowing_symbols, cl},
{"LIST-ALL-PACKAGES", Llist_all_packages, cl},
{"INTERN", Lintern, cl},
{"FIND-SYMBOL", Lfind_symbol, cl},
{"UNINTERN", Lunintern, cl},
{"EXPORT", Lexport, cl},
{"UNEXPORT", Lunexport, cl},
{"IMPORT", Limport, cl},
{"SHADOWING-IMPORT", Lshadowing_import, cl},
{"SHADOW", Lshadow, cl},
{"USE-PACKAGE", Luse_package, cl},
{"UNUSE-PACKAGE", Lunuse_package, cl},
{"DELETE-PACKAGE", Ldelete_package, cl},
{"PACKAGE-SIZE", siLpackage_size, si},
{"PACKAGE-INTERNAL", siLpackage_internal, si},
{"PACKAGE-EXTERNAL", siLpackage_external, si},
{"PACKAGE-LOCK", siLpackage_lock, si},
/* pathname.d */
{"PATHNAME", Lpathname, cl},
{"PARSE-NAMESTRING", Lparse_namestring, cl},
{"MERGE-PATHNAMES", Lmerge_pathnames, cl},
{"MAKE-PATHNAME", Lmake_pathname, cl},
{"PATHNAMEP", Lpathnamep, cl},
{"PATHNAME-HOST", Lpathname_host, cl},
{"PATHNAME-DEVICE", Lpathname_device, cl},
{"PATHNAME-DIRECTORY", Lpathname_directory, cl},
{"PATHNAME-NAME", Lpathname_name, cl},
{"PATHNAME-TYPE", Lpathname_type, cl},
{"PATHNAME-VERSION", Lpathname_version, cl},
{"NAMESTRING", Lnamestring, cl},
{"FILE-NAMESTRING", Lfile_namestring, cl},
{"DIRECTORY-NAMESTRING", Ldirectory_namestring, cl},
{"HOST-NAMESTRING", Lhost_namestring, cl},
{"ENOUGH-NAMESTRING", Lenough_namestring, cl},
{"LOGICAL-PATHNAME-P", siLlogical_pathname_p, si},
{"PATHNAME-MATCH-P", Lpathname_match_p, cl},
{"TRANSLATE-PATHNAME", Ltranslate_pathname, cl},
{"TRANSLATE-LOGICAL-PATHNAME", Ltranslate_logical_pathname, cl},
{"PATHNAME-TRANSLATIONS", siLpathname_translations, si},
/* predicate.c */
{"IDENTITY", Lidentity, cl},
{"NULL", Lnull, cl},
{"SYMBOLP", Lsymbolp, cl},
{"ATOM", Latom, cl},
{"CONSP", Lconsp, cl},
{"LISTP", Llistp, cl},
{"NUMBERP", Lnumberp, cl},
{"INTEGERP", Lintegerp, cl},
{"RATIONALP", Lrationalp, cl},
{"FLOATP", Lfloatp, cl},
{"REALP", Lrealp, cl},
{"COMPLEXP", Lcomplexp, cl},
{"CHARACTERP", Lcharacterp, cl},
{"STRINGP", Lstringp, cl},
{"BIT-VECTOR-P", Lbit_vector_p, cl},
{"VECTORP", Lvectorp, cl},
{"SIMPLE-STRING-P", Lsimple_string_p, cl},
{"SIMPLE-BIT-VECTOR-P", Lsimple_bit_vector_p, cl},
{"SIMPLE-VECTOR-P", Lsimple_vector_p, cl},
{"ARRAYP", Larrayp, cl},
{"PACKAGEP", Lpackagep, cl},
{"FUNCTIONP", Lfunctionp, cl},
{"COMPILED-FUNCTION-P", Lcompiled_function_p, cl},
{"COMMONP", Lcommonp, cl},
{"EQ", Leq, cl},
{"EQL", Leql, cl},
{"EQUAL", Lequal, cl},
{"EQUALP", Lequalp, cl},
{"NOT", Lnull, cl},
{"CONTAINS-SHARP-COMMA", siLcontains_sharp_comma, si},
{"FIXNUMP", siLfixnump, si},
/* print.d */
{"WRITE", Lwrite, cl},
{"PRIN1", Lprin1, cl},
{"PRINT", Lprint, cl},
{"PPRINT", Lpprint, cl},
{"PRINC", Lprinc, cl},
{"WRITE-CHAR", Lwrite_char, cl},
{"WRITE-STRING", Lwrite_string, cl},
{"WRITE-LINE", Lwrite_line, cl},
{"WRITE-BYTE", Lwrite_byte, cl},
{"WRITE-BYTES", Lwrite_bytes, si},
{"TERPRI", Lterpri, cl},
{"FRESH-LINE", Lfresh_line, cl},
{"FINISH-OUTPUT", Lforce_output, cl},
{"FORCE-OUTPUT", Lforce_output, cl},
{"CLEAR-OUTPUT", Lclear_output, cl},
/* profile.c */
#ifdef PROFILE
{"PROFILE", siLprofile, si},
{"CLEAR-PROFILE", siLclear_profile, si},
{"DISPLAY-PROFILE", siLdisplay_profile, si},
#endif PROFILE
/* prog.c */
{"TAGBODY", NULL, form},
{"PROG", NULL, form},
{"PROG*", NULL, form},
{"GO", NULL, form},
{"PROGV", NULL, form},
{"PROGN", NULL, form},
{"PROG1", NULL, form},
{"PROG2", NULL, form},
/* read.d */
{"READ", Lread, cl},
{"READ-PRESERVING-WHITESPACE", Lread_preserving_whitespace, cl},
{"READ-DELIMITED-LIST", Lread_delimited_list, cl},
{"READ-LINE", Lread_line, cl},
{"READ-CHAR", Lread_char, cl},
{"UNREAD-CHAR", Lunread_char, cl},
{"PEEK-CHAR", Lpeek_char, cl},
{"LISTEN", Llisten, cl},
{"READ-CHAR-NO-HANG", Lread_char_no_hang, cl},
{"CLEAR-INPUT", Lclear_input, cl},
{"PARSE-INTEGER", Lparse_integer, cl},
{"READ-BYTE", Lread_byte, cl},
{"READ-BYTES", Lread_bytes, si},
{"COPY-READTABLE", Lcopy_readtable, cl},
{"READTABLEP", Lreadtablep, cl},
{"SET-SYNTAX-FROM-CHAR", Lset_syntax_from_char, cl},
{"SET-MACRO-CHARACTER", Lset_macro_character, cl},
{"GET-MACRO-CHARACTER", Lget_macro_character, cl},
{"MAKE-DISPATCH-MACRO-CHARACTER", Lmake_dispatch_macro_character, cl},
{"SET-DISPATCH-MACRO-CHARACTER", Lset_dispatch_macro_character, cl},
{"GET-DISPATCH-MACRO-CHARACTER", Lget_dispatch_macro_character, cl},
{"SHARP-COMMA-READER-FOR-COMPILER", siLsharp_comma_reader_for_compiler, si},
{"STRING-TO-OBJECT", siLstring_to_object, si},
{"STANDARD-READTABLE", siLstandard_readtable, si},
/* reference.c */
{"SYMBOL-FUNCTION", Lsymbol_function, cl},
{"FBOUNDP", Lfboundp, cl},
{"QUOTE", NULL, form},
{"SYMBOL-VALUE", Lsymbol_value, cl},
{"BOUNDP", Lboundp, cl},
{"MACRO-FUNCTION", Lmacro_function, cl},
{"SPECIAL-FORM-P", Lspecial_form_p, cl},
{"COERCE-TO-FUNCTION", siLcoerce_to_function, si},
{"FUNCTION", NULL, form},
{"PROCESS-DECLARATIONS", siLprocess_declarations, si},
{"PROCESS-LAMBDA-LIST", siLprocess_lambda_list, si},
/* sequence.d */
{"ELT", Lelt, cl},
{"ELT-SET", siLelt_set, si},
{"SUBSEQ", Lsubseq, cl},
{"COPY-SEQ", Lcopy_seq, cl},
{"LENGTH", Llength, cl},
{"REVERSE", Lreverse, cl},
{"NREVERSE", Lnreverse, cl},
/* stacks.c */
{"IHS-TOP", siLihs_top, si},
{"IHS-FUN", siLihs_fun, si},
{"IHS-ENV", siLihs_env, si},
{"FRS-TOP", siLfrs_top, si},
{"FRS-BDS", siLfrs_bds, si},
{"FRS-CLASS", siLfrs_class, si},
{"FRS-TAG", siLfrs_tag, si},
{"FRS-IHS", siLfrs_ihs, si},
{"BDS-TOP", siLbds_top, si},
{"BDS-VAR", siLbds_var, si},
{"BDS-VAL", siLbds_val, si},
{"SCH-FRS-BASE", siLsch_frs_base, si},
{"RESET-STACK-LIMITS", siLreset_stack_limits, si},
/* string.d */
{"CHAR", Lchar, cl},
{"CHAR-SET", siLchar_set, si},
{"SCHAR", Lchar, cl},
{"SCHAR-SET", siLchar_set, si},
{"STRING=", Lstring_eq, cl},
{"STRING-EQUAL", Lstring_equal, cl},
{"STRING<", Lstring_l, cl},
{"STRING>", Lstring_g, cl},
{"STRING<=", Lstring_le, cl},
{"STRING>=", Lstring_ge, cl},
{"STRING/=", Lstring_neq, cl},
{"STRING-LESSP", Lstring_lessp, cl},
{"STRING-GREATERP", Lstring_greaterp, cl},
{"STRING-NOT-LESSP", Lstring_not_lessp, cl},
{"STRING-NOT-GREATERP", Lstring_not_greaterp, cl},
{"STRING-NOT-EQUAL", Lstring_not_equal, cl},
{"MAKE-STRING", Lmake_string, cl},
{"STRING-TRIM", Lstring_trim, cl},
{"STRING-LEFT-TRIM", Lstring_left_trim, cl},
{"STRING-RIGHT-TRIM", Lstring_right_trim, cl},
{"STRING-UPCASE", Lstring_upcase, cl},
{"STRING-DOWNCASE", Lstring_downcase, cl},
{"STRING-CAPITALIZE", Lstring_capitalize, cl},
{"NSTRING-UPCASE", Lnstring_upcase, cl},
{"NSTRING-DOWNCASE", Lnstring_downcase, cl},
{"NSTRING-CAPITALIZE", Lnstring_capitalize, cl},
{"STRING", Lstring, cl},
{"STRING-CONCATENATE", siLstring_concatenate, si},
/* structure.c */
{"MAKE-STRUCTURE", siLmake_structure, si},
{"COPY-STRUCTURE", siLcopy_structure, si},
{"STRUCTURE-NAME", siLstructure_name, si},
{"STRUCTURE-REF", siLstructure_ref, si},
{"STRUCTURE-SET", siLstructure_set, si},
{"STRUCTUREP", siLstructurep, si},
{"STRUCTURE-SUBTYPE-P", siLstructure_subtype_p, si},
{"RPLACA-NTHCDR", siLrplaca_nthcdr, si},
{"LIST-NTH", siLlist_nth, si},
/* symbol.d */
{"GET", Lget, cl},
{"REMPROP", Lremprop, cl},
{"SYMBOL-PLIST", Lsymbol_plist, cl},
{"GETF", Lgetf, cl},
{"GET-PROPERTIES", Lget_properties, cl},
{"SYMBOL-NAME", Lsymbol_name, cl},
{"MAKE-SYMBOL", Lmake_symbol, cl},
{"COPY-SYMBOL", Lcopy_symbol, cl},
{"GENSYM", Lgensym, cl},
{"GENTEMP", Lgentemp, cl},
{"SYMBOL-PACKAGE", Lsymbol_package, cl},
{"KEYWORDP", Lkeywordp, cl},
{"PUT-F", siLput_f, si},
{"REM-F", siLrem_f, si},
{"SET-SYMBOL-PLIST", siLset_symbol_plist, si},
{"PUTPROP", siLputprop, si},
{"PUT-PROPERTIES", siLput_properties, si},
/* tcp.c */
#ifdef TCP
{"OPEN-CLIENT-STREAM", Lopen_client_stream, si},
{"OPEN-SERVER-STREAM", Lopen_server_stream, si},
#endif
/* time.c */
{"GET-UNIVERSAL-TIME", Lget_universal_time, cl},
{"SLEEP", Lsleep, cl},
{"GET-INTERNAL-RUN-TIME", Lget_internal_run_time, cl},
{"GET-INTERNAL-REAL-TIME", Lget_internal_real_time, cl},
{"GET-LOCAL-TIME-ZONE", Lget_local_time_zone, si},
{"DAYLIGHT-SAVING-TIME-P", Ldaylight_saving_timep, si},
/* toplevel.c */
{"LAMBDA", NULL, form},
{"NAMED-LAMBDA", NULL, form},
{"*MAKE-SPECIAL", siLAmake_special, si},
{"*MAKE-CONSTANT", siLAmake_constant, si},
{"EVAL-WHEN", NULL, form},
{"THE", NULL, form},
{"DECLARE", NULL, form},
{"LOCALLY", NULL, form},
/* typespec.c */
{"TYPE-OF", Ltype_of, cl},
/* unify.d */
#ifdef LOCATIVE
{"TRAIL-MARK", Ltrail_mark, si},
{"TRAIL-UNMARK", Ltrail_unmark, si},
{"TRAIL-RESTORE", Ltrail_restore, si},
{"GET-VARIABLE", NULL, form},
{"GET-VALUE", Lget_value, si},
{"GET-CONSTANT", Lget_constant, si},
{"GET-NIL", Lget_nil, si},
{"GET-CONS", Lget_cons, si},
{"GET-INSTANCE", Lget_instance, si}, /* Mauro */
{"UNIFY-SLOT", Lunify_slot, si},
{"UNIFY-VALUE", Lunify_value, si},
{"UNIFY-CONSTANT", Lunify_constant, si},
{"UNIFY-NIL", Lunify_nil, si},
{"MAKE-LOCATIVE", Lmake_locative, si},
{"LOCATIVEP", Llocativep, si},
{"UNBOUNDP", Lunboundp, si},
{"MAKE-VARIABLE", Lmake_variable, si},
{"DEREFERENCE", Ldereference, si},
#endif LOCATIVE
/* unixint.c */
#ifdef unix
{"CATCH-BAD-SIGNALS", siLcatch_bad_signals, si},
{"UNCATCH-BAD-SIGNALS", siLuncatch_bad_signals, si},
#endif unix
/* unixfsys.c */
{"TRUENAME", Ltruename, cl},
{"RENAME-FILE", Lrename_file, cl},
{"DELETE-FILE", Ldelete_file, cl},
{"PROBE-FILE", Lprobe_file, cl},
{"FILE-WRITE-DATE", Lfile_write_date, cl},
{"FILE-AUTHOR", Lfile_author, cl},
{"USER-HOMEDIR-PATHNAME", Luser_homedir_pathname, cl},
{"STRING-MATCH", siLstring_match, si},
{"DIRECTORY", Ldirectory, cl},
{"CHDIR", siLchdir, si},
/* unixsys.c */
{"SYSTEM", siLsystem, si},
{"OPEN-PIPE", siLopen_pipe, si},
/* end of list */
{NULL, NULL, 0}
};
void
init_all_functions(void) {
const struct function_info *f = all_functions;
for (f = all_functions; f->name != NULL; f++) {
switch (f->type) {
case cl:
make_function(f->name, f->f);
break;
case si:
make_si_function(f->name, f->f);
break;
case form: {
cl_object s = make_ordinary(f->name);
s->symbol.isform = TRUE;
s->symbol.mflag = FALSE;
}
}
}
}

141
src/c/all_keywords.d Normal file
View file

@ -0,0 +1,141 @@
/*
all_keywords.d -- All named keywords.
*/
/*
Copyright (c) 2001, Juan Jose Garcia Ripoll.
ECLS 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.
See file '../Copyright' for full details.
*/
#include "ecls.h"
#include "page.h"
const struct keyword_info all_keywords[] = {
/* bind.c */
{&Kallow_other_keys, "ALLOW-OTHER-KEYS"},
/* error.c */
{&Kpathname, "PATHNAME"},
{&Kdatum, "DATUM"},
{&Kexpected_type, "EXPECTED-TYPE"},
{&Kformat_control, "FORMAT-CONTROL"},
{&Kformat_arguments, "FORMAT-ARGUMENTS"},
/* file.c */
{&Kerror, "ERROR"},
{&Kabort, "ABORT"},
{&Kdirection, "DIRECTION"},
{&Kinput, "INPUT"},
{&Koutput, "OUTPUT"},
{&Kio, "IO"},
{&Kprobe, "PROBE"},
{&Kelement_type, "ELEMENT-TYPE"},
{&Kdefault, "DEFAULT"},
{&Kif_exists, "IF-EXISTS"},
{&Knew_version, "NEW-VERSION"},
{&Krename, "RENAME"},
{&Krename_and_delete, "RENAME-AND-DELETE"},
{&Koverwrite, "OVERWRITE"},
{&Kappend, "APPEND"},
{&Ksupersede, "SUPERSEDE"},
{&Kcreate, "CREATE"},
{&Kprint, "PRINT"},
{&Kif_does_not_exist, "IF-DOES-NOT-EXIST"},
{&Kset_default_pathname, "SET-DEFAULT-PATHNAME"},
/* hash.c */
{&Ksize, "SIZE"},
{&Krehash_size, "REHASH-SIZE"},
{&Krehash_threshold, "REHASH-THRESHOLD"},
/* list.c */
{&Ktest, "TEST"},
{&Ktest_not, "TEST-NOT"},
{&Kkey, "KEY"},
{&Kinitial_element, "INITIAL-ELEMENT"},
/* load.c */
{&Kverbose, "VERBOSE"},
/* package.c */
{&Kinternal, "INTERNAL"},
{&Kexternal, "EXTERNAL"},
{&Kinherited, "INHERITED"},
{&Knicknames, "NICKNAMES"},
{&Kuse, "USE"},
/* pathname.c */
{&Kwild, "WILD"},
{&Kwild_inferiors, "WILD-INFERIORS"},
{&Knewest, "NEWEST"},
{&Khost, "HOST"},
{&Kdevice, "DEVICE"},
{&Kdirectory, "DIRECTORY"},
{&Kname, "NAME"},
{&Ktype, "TYPE"},
{&Kversion, "VERSION"},
{&Kdefaults, "DEFAULTS"},
{&Kabsolute, "ABSOLUTE"},
{&Krelative, "RELATIVE"},
{&Kup, "UP"},
/* print.c */
{&Kupcase, "UPCASE"},
{&Kdowncase, "DOWNCASE"},
{&Kcapitalize, "CAPITALIZE"},
{&Kstream, "STREAM"},
{&Kescape, "ESCAPE"},
{&Kpretty, "PRETTY"},
{&Kcircle, "CIRCLE"},
{&Kbase, "BASE"},
{&Kradix, "RADIX"},
{&Kcase, "CASE"},
{&Kgensym, "GENSYM"},
{&Klevel, "LEVEL"},
{&Klength, "LENGTH"},
{&Karray, "ARRAY"},
/* read.c */
{&Kjunk_allowed, "JUNK-ALLOWED"},
/* stacks.d */
{&Kcatch, "CATCH"},
{&Kcatchall, "CATCHALL"},
{&Kprotect, "PROTECT"},
/* string.c */
{&Kstart1, "START1"},
{&Kend1, "END1"},
{&Kstart2, "START2"},
{&Kend2, "END2"},
{&Kstart, "START"},
{&Kend, "END"},
/* toplevel */
{&Kexecute, "EXECUTE"},
{&Kcompile_toplevel, "COMPILE-TOPLEVEL"},
{&Kload_toplevel, "LOAD-TOPLEVEL"},
/* unixfsys.c */
{&Klist_all, "LIST-ALL"},
/* END */
{NULL, (const char*)NULL}};
void
init_all_keywords(void)
{
const struct keyword_info *k = all_keywords;
cl_object *keyword_loc;
while (k->name != NULL) {
keyword_loc = k->loc;
*keyword_loc = make_keyword(k->name);
k++;
}
}

343
src/c/all_symbols.d Normal file
View file

@ -0,0 +1,343 @@
#include "ecls.h"
#include "page.h"
const struct symbol_info all_symbols[] = {
/* assignment.c */
{&Ssetf, "SETF", CL_ORDINARY},
{&Spsetf, "PSETF", CL_ORDINARY},
{&siSsetf_symbol, "SETF-SYMBOL", SI_ORDINARY},
{&siSclear_compiler_properties, "CLEAR-COMPILER-PROPERTIES", SI_ORDINARY},
#ifdef PDE
{&siVrecord_source_pathname_p, "*RECORD-SOURCE-PATHNAME-P*", SI_SPECIAL},
{&siSrecord_source_pathname, "RECORD-SOURCE-PATHNAME", SI_ORDINARY},
#endif
/* backq.c */
{&siScomma, ",", SI_ORDINARY},
{&siScomma_at, ",@@", SI_ORDINARY},
{&siScomma_dot, ",.", SI_ORDINARY},
{&SlistX, "LIST*", CL_ORDINARY},
{&Sappend, "APPEND", CL_ORDINARY},
{&Snconc, "NCONC", CL_ORDINARY},
/* bind.c */
{&SAoptional, "&OPTIONAL", CL_ORDINARY},
{&SArest, "&REST", CL_ORDINARY},
{&SAkey, "&KEY", CL_ORDINARY},
{&SAallow_other_keys, "&ALLOW-OTHER-KEYS", CL_ORDINARY},
{&SAaux, "&AUX", CL_ORDINARY},
/* block.c */
{&Sblock, "BLOCK", CL_ORDINARY},
/* clos.c */
#ifdef CLOS
{&siSXclass_name_hash_tableX, "*CLASS-NAME-HASH-TABLE*", SI_SPECIAL},
{&Sclass, "CLASS", CL_ORDINARY},
{&Sbuilt_in, "BUILT-IN", CL_ORDINARY},
#endif
/* compiler.c */
{&siSlambda_block, "LAMBDA-BLOCK", CL_ORDINARY},
/* conditional.c */
{&Sotherwise, "OTHERWISE", CL_ORDINARY},
/* error.c */
{&Sarithmetic_error, "ARITHMETIC-ERROR", CL_ORDINARY},
{&Scell_error, "CELL-ERROR", CL_ORDINARY},
{&Scondition, "CONDITION", CL_ORDINARY},
{&Sdivision_by_zero, "DIVISION-BY-ZERO", CL_ORDINARY},
{&Send_of_file, "END-OF-FILE", CL_ORDINARY},
{&Serror, "ERROR", CL_ORDINARY},
{&Sfile_error, "FILE-ERROR", CL_ORDINARY},
{&Sfloating_point_inexact, "FLOATING-POINT-INEXACT", CL_ORDINARY},
{&Sfloating_point_invalid_operation, "FLOATING-POINT-INVALID-OPERATION", CL_ORDINARY},
{&Sfloating_point_overflow, "FLOATING-POINT-OVERFLOW", CL_ORDINARY},
{&Sfloating_point_underflow, "FLOATING-POINT-UNDERFLOW", CL_ORDINARY},
{&Spackage_error, "PACKAGE-ERROR", CL_ORDINARY},
{&Sparse_error, "PARSE-ERROR", CL_ORDINARY},
{&Sprint_not_readable, "PRINT-NOT-READABLE", CL_ORDINARY},
{&Sprogram_error, "PROGRAM-ERROR", CL_ORDINARY},
{&Sreader_error, "READER-ERROR", CL_ORDINARY},
{&Sserious_condition, "SERIOUS-CONDITION", CL_ORDINARY},
{&Ssimple_condition, "SIMPLE-CONDITION", CL_ORDINARY},
{&Ssimple_error, "SIMPLE-ERROR", CL_ORDINARY},
{&Ssimple_type_error, "SIMPLE-TYPE-ERROR", CL_ORDINARY},
{&Ssimple_warning, "SIMPLE-WARNING", CL_ORDINARY},
{&Sstorage_condition, "STORAGE-CONDITION", CL_ORDINARY},
{&Sstream_error, "STREAM-ERROR", CL_ORDINARY},
{&Sstyle_warning, "STYLE-WARNING", CL_ORDINARY},
{&Stype_error, "TYPE-ERROR", CL_ORDINARY},
{&Sunbound_slot, "UNBOUND-SLOT", CL_ORDINARY},
{&Sunbound_variable, "UNBOUND-VARIABLE", CL_ORDINARY},
{&Sundefined_function, "UNDEFINED-FUNCTION", CL_ORDINARY},
{&Swarning, "WARNING", CL_ORDINARY},
{&siSsimple_program_error, "SIMPLE-PROGRAM-ERROR", SI_ORDINARY},
{&siSsimple_control_error, "SIMPLE-CONTROL-ERROR", SI_ORDINARY},
{&siSuniversal_error_handler, "UNIVERSAL-ERROR-HANDLER", SI_ORDINARY},
{&siSterminal_interrupt, "TERMINAL-INTERRUPT", SI_ORDINARY},
/* eval.c */
{&Sapply, "APPLY", CL_ORDINARY},
{&Sfuncall, "FUNCALL", CL_ORDINARY},
{&Vevalhook, "*EVALHOOK*", CL_SPECIAL},
{&Vapplyhook, "*APPLYHOOK*", CL_SPECIAL},
/* file.c */
{&Vstandard_input, "*STANDARD-INPUT*", CL_SPECIAL},
{&Vstandard_output, "*STANDARD-OUTPUT*", CL_SPECIAL},
{&Verror_output, "*ERROR-OUTPUT*", CL_SPECIAL},
{&Vquery_io, "*QUERY-IO*", CL_SPECIAL},
{&Vdebug_io, "*DEBUG-IO*", CL_SPECIAL},
{&Vterminal_io, "*TERMINAL-IO*", CL_SPECIAL},
{&Vtrace_output, "*TRACE-OUTPUT*", CL_SPECIAL},
{&siVignore_eof_on_terminal_io, "*IGNORE-EOF-ON-TERMINAL-IO*", SI_SPECIAL},
/* format.c */
{&siVindent_formatted_output, "*INDENT-FORMATTED-OUTPUT*", SI_SPECIAL},
/* gbc.c */
#if 0 && !defined(GBC_BOEHM)
{&siVgc_verbose, "*GC-VERBOSE*", SI_SPECIAL},
{&siVgc_message, "*GC-MESSAGE*", SI_SPECIAL},
#endif /* !GBC_BOEHM */
/* gfun.c */
{&siScompute_applicable_methods, "COMPUTE-APPLICABLE-METHODS", SI_ORDINARY},
{&siScompute_effective_method, "COMPUTE-EFFECTIVE-METHOD", SI_ORDINARY},
{&siSgeneric_function_method_combination, "GENERIC-FUNCTION-METHOD-COMBINATION", SI_ORDINARY},
{&siSgeneric_function_method_combination_args, "GENERIC-FUNCTION-METHOD-COMBINATION-ARGS", SI_ORDINARY},
/* hash.c */
{&Seq, "EQ", CL_ORDINARY},
{&Seql, "EQL", CL_ORDINARY},
{&Sequal, "EQUAL", CL_ORDINARY},
/* instance.c */
{&Sprint_object, "PRINT-OBJECT", CL_ORDINARY},
/* lex.c */
{&Smacro, "MACRO", CL_ORDINARY},
{&siSsymbol_macro, "SYMBOL-MACRO", SI_ORDINARY},
{&Stag, "TAG", CL_ORDINARY},
/* load.c */
{&Vload_verbose, "*LOAD-VERBOSE*", CL_SPECIAL},
{&Vload_print, "*LOAD-PRINT*", CL_SPECIAL},
{&siVload_hooks, "*LOAD-HOOKS*", SI_SPECIAL},
#ifdef PDE
{&siVsource_pathname, "*SOURCE-PATHNAME*", CL_SPECIAL},
#endif
#ifdef RSYM
{&siVsymbol_table, "*SYMBOL-TABLE*", CL_SPECIAL},
#endif
/* lwp.c */
#ifdef THREADS
{&Srunning, "RUNNING", CL_ORDINARY},
{&Ssuspended, "SUSPENDED", CL_ORDINARY},
{&Swaiting, "WAITING", CL_ORDINARY},
{&Sstopped, "STOPPED", CL_ORDINARY},
{&Sdead, "DEAD", CL_ORDINARY},
{&siSthread_top_level, "THREAD-TOP-LEVEL", SI_ORDINARY},
#endif
/* macros.c */
{&Vmacroexpand_hook, "*MACROEXPAND-HOOK*", CL_SPECIAL},
{&siSexpand_defmacro, "EXPAND-DEFMACRO", SI_ORDINARY},
{&siVinhibit_macro_special, "*INHIBIT-MACRO-SPECIAL*", SI_SPECIAL},
/* main.c */
{&siVsystem_directory, "*SYSTEM-DIRECTORY*", SI_SPECIAL},
{&Vfeatures, "*FEATURES*", CL_SPECIAL},
/* num_rand.c */
{&Vrandom_state, "*RANDOM-STATE*", CL_SPECIAL},
/* package.c */
{&Vpackage, "*PACKAGE*", CL_SPECIAL},
/* pathname.c */
{&Vdefault_pathname_defaults, "*DEFAULT-PATHNAME-DEFAULTS*", CL_SPECIAL},
/* print.c */
{&Vprint_escape, "*PRINT-ESCAPE*", CL_SPECIAL},
{&Vprint_pretty, "*PRINT-PRETTY*", CL_SPECIAL},
{&Vprint_circle, "*PRINT-CIRCLE*", CL_SPECIAL},
{&Vprint_base, "*PRINT-BASE*", CL_SPECIAL},
{&Vprint_radix, "*PRINT-RADIX*", CL_SPECIAL},
{&Vprint_case, "*PRINT-CASE*", CL_SPECIAL},
{&Vprint_gensym, "*PRINT-GENSYM*", CL_SPECIAL},
{&Vprint_level, "*PRINT-LEVEL*", CL_SPECIAL},
{&Vprint_length, "*PRINT-LENGTH*", CL_SPECIAL},
{&Vprint_array, "*PRINT-ARRAY*", CL_SPECIAL},
{&siSpretty_print_format, "PRETTY-PRINT-FORMAT", SI_ORDINARY},
{&siSsharp_exclamation, "#!", SI_ORDINARY},
{&siVprint_package, "*PRINT-PACKAGE*", SI_SPECIAL},
{&siVprint_structure, "*PRINT-STRUCTURE*", SI_SPECIAL},
#ifdef CLOS
{&Sstream_write_char, "STREAM-WRITE-CHAR", CL_ORDINARY},
{&Sstream_write_string, "STREAM-WRITE-STRING", CL_ORDINARY},
{&Sstream_fresh_line, "STREAM-FRESH-LINE", CL_ORDINARY},
{&Sstream_clear_output, "STREAM-CLEAR-OUTPUT", CL_ORDINARY},
{&Sstream_force_output, "STREAM-FORCE-OUTPUT", CL_ORDINARY},
#endif
/* profile.c */
#ifdef PROFILE
{&sSAprofile_arrayA, "*PROFILE-ARRAY*", SI_SPECIAL},
#endif PROFILE
/* read.c */
{&Vreadtable, "*READTABLE*", CL_SPECIAL},
{&Vread_default_float_format, "*READ-DEFAULT-FLOAT-FORMAT*", CL_SPECIAL},
{&Vread_base, "*READ-BASE*", CL_SPECIAL},
{&Vread_suppress, "*READ-SUPPRESS*", CL_SPECIAL},
{&siSsharp_comma, "#,", SI_ORDINARY},
#ifdef CLOS
{&Sstream_read_line, "STREAM-READ-LINE", CL_ORDINARY},
{&Sstream_read_char, "STREAM-READ-CHAR", CL_ORDINARY},
{&Sstream_unread_char, "STREAM-UNREAD-CHAR", CL_ORDINARY},
{&Sstream_peek_char, "STREAM-PEEK-CHAR", CL_ORDINARY},
{&Sstream_listen, "STREAM-LISTEN", CL_ORDINARY},
{&Sstream_clear_input, "STREAM-CLEAR-INPUT", CL_ORDINARY},
#endif
/* structure.c */
{&siSstructure_print_function, "STRUCTURE-PRINT-FUNCTION", SI_ORDINARY},
{&siSstructure_slot_descriptions, "STRUCTURE-SLOT-DESCRIPTIONS", SI_ORDINARY},
#ifndef CLOS
{&siSstructure_include, "STRUCTURE-INCLUDE", SI_ORDINARY},
#else
{&Sstructure_object, "STRUCTURE-OBJECT", CL_ORDINARY},
#endif
/* symbol.c */
{&siSpname, "PNAME", SI_ORDINARY},
{&Vgensym_counter, "*GENSYM-COUNTER*", CL_SPECIAL},
/* toplevel.c */
{&Sdeclare, "DECLARE", CL_ORDINARY},
{&Scompile, "COMPILE", CL_ORDINARY},
{&Sload, "LOAD", CL_ORDINARY},
{&Seval, "EVAL", CL_ORDINARY},
{&Sprogn, "PROGN", CL_ORDINARY},
{&Swarn, "WARN", CL_ORDINARY},
{&Stypep, "TYPEP", CL_ORDINARY},
/* typespec.c */
{&Squote, "QUOTE", CL_ORDINARY},
{&Slambda, "LAMBDA", CL_ORDINARY},
{&Sspecial, "SPECIAL", CL_ORDINARY},
{&St, "T", CL_ORDINARY},
{&Snil, "NIL", CL_ORDINARY},
{&Scommon, "COMMON", CL_ORDINARY},
{&Ssequence, "SEQUENCE", CL_ORDINARY},
{&Snull, "NULL", CL_ORDINARY},
{&Scons, "CONS", CL_ORDINARY},
{&Slist, "LIST", CL_ORDINARY},
{&Ssymbol, "SYMBOL", CL_ORDINARY},
{&Sarray, "ARRAY", CL_ORDINARY},
{&Svector, "VECTOR", CL_ORDINARY},
{&Sbit_vector, "BIT-VECTOR", CL_ORDINARY},
{&Sstring, "STRING", CL_ORDINARY},
{&Ssimple_array, "SIMPLE-ARRAY", CL_ORDINARY},
{&Ssimple_vector, "SIMPLE-VECTOR", CL_ORDINARY},
{&Ssimple_string, "SIMPLE-STRING", CL_ORDINARY},
{&Ssimple_bit_vector, "SIMPLE-BIT-VECTOR", CL_ORDINARY},
{&Sfunction, "FUNCTION", CL_ORDINARY},
{&Spathname, "PATHNAME", CL_ORDINARY},
{&Slogical_pathname, "LOGICAL-PATHNAME", CL_ORDINARY},
{&Scharacter, "CHARACTER", CL_ORDINARY},
{&Sbase_char, "BASE-CHAR", CL_ORDINARY},
{&Sextended_char, "EXTENDED-CHAR", CL_ORDINARY},
{&Scompiled_function, "COMPILED-FUNCTION", CL_ORDINARY},
{&Snumber, "NUMBER", CL_ORDINARY},
{&Sreal, "REAL", CL_ORDINARY},
{&Srational, "RATIONAL", CL_ORDINARY},
{&Sfloat, "FLOAT", CL_ORDINARY},
{&Sinteger, "INTEGER", CL_ORDINARY},
{&Sratio, "RATIO", CL_ORDINARY},
{&Sshort_float, "SHORT-FLOAT", CL_ORDINARY},
{&Sstandard_char, "STANDARD-CHAR", CL_ORDINARY},
{&Sfixnum, "FIXNUM", CL_ORDINARY},
{&Scomplex, "COMPLEX", CL_ORDINARY},
{&Ssingle_float, "SINGLE-FLOAT", CL_ORDINARY},
{&Spackage, "PACKAGE", CL_ORDINARY},
{&Sbignum, "BIGNUM", CL_ORDINARY},
{&Srandom_state, "RANDOM-STATE", CL_ORDINARY},
{&Sdouble_float, "DOUBLE-FLOAT", CL_ORDINARY},
{&Sstream, "STREAM", CL_ORDINARY},
{&Sbit, "BIT", CL_ORDINARY},
{&Sreadtable, "READTABLE", CL_ORDINARY},
{&Slong_float, "LONG-FLOAT", CL_ORDINARY},
{&Shash_table, "HASH-TABLE", CL_ORDINARY},
{&Ssigned_char, "SIGNED-CHAR", CL_ORDINARY},
{&Sunsigned_char, "UNSIGNED-CHAR", CL_ORDINARY},
{&Ssigned_short, "SIGNED-SHORT", CL_ORDINARY},
{&Sunsigned_short, "UNSIGNED-SHORT", CL_ORDINARY},
#ifdef CLOS
{&Sinstance, "INSTANCE", CL_ORDINARY},
{&Sdispatch_function, "DISPATCH-FUNCTION", CL_ORDINARY},
{&Sstructure, "STRUCTURE", CL_ORDINARY},
#endif
{&Ssatisfies, "SATISFIES", CL_ORDINARY},
{&Smember, "MEMBER", CL_ORDINARY},
{&Snot, "NOT", CL_ORDINARY},
{&Sor, "OR", CL_ORDINARY},
{&Sand, "AND", CL_ORDINARY},
{&Svalues, "VALUES", CL_ORDINARY},
{&Smod, "MOD", CL_ORDINARY},
{&Ssigned_byte, "SIGNED-BYTE", CL_ORDINARY},
{&Sunsigned_byte, "UNSIGNED-BYTE", CL_ORDINARY},
{&SX, "*", CL_ORDINARY},
{&Splusp, "PLUSP", CL_ORDINARY},
{&Skeyword, "KEYWORD", CL_ORDINARY},
#ifdef THREADS
{&Scont, "CONT", CL_ORDINARY},
{&Sthread, "THREAD", CL_ORDINARY},
#endif
#ifdef LOCATIVE
{&Slocative, "LOCATIVE", CL_ORDINARY},
#endif
{&Ssubtypep, "SUBTYPEP", CL_ORDINARY},
/* unify.c */
#ifdef LOCATIVE
{&Ssetq, "SETQ", CL_ORDINARY},
{&Sunify_slot, "UNIFY-SLOT", CL_ORDINARY},
#endif
{NULL, (const char*)NULL, CL_ORDINARY}};
void
init_all_symbols(void) {
const struct symbol_info *s = all_symbols;
cl_object *loc;
/* This must keep the garbage collector happy */
for (s = all_symbols; s->name != NULL; s++)
*(s->loc) = OBJNULL;
for (s = all_symbols; s->name != NULL; s++) {
loc = s->loc;
switch (s->type) {
case CL_ORDINARY:
*loc = make_ordinary(s->name);
break;
case CL_SPECIAL:
*loc = make_special(s->name, Cnil);
break;
case SI_ORDINARY:
*loc = make_si_ordinary(s->name);
break;
case SI_SPECIAL:
*loc = make_si_special(s->name, Cnil);
break;
}
/* register_root(loc);*/
}
}

900
src/c/alloc.d Normal file
View file

@ -0,0 +1,900 @@
/*
alloc.c -- Memory allocation.
*/
/*
Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
Copyright (c) 1990, Giuseppe Attardi.
Copyright (c) 2001, Juan Jose Garcia Ripoll.
ECLS 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.
See file '../Copyright' for full details.
*/
/*
Heap and Relocatable Area
heap_end data_end
+------+--------------------+ - - - + - - --------+
| text | heap | hole | stack |
+------+--------------------+ - - - + - - --------+
The type_map array covers all pages of memory: those not used for objects
are marked as type t_other.
The tm_table array holds a struct typemanager for each type, which contains
the first element of the free list for the type, and other bookkeeping
information.
*/
#include "ecls.h"
#include "page.h"
#ifdef BSD
#include <sys/resource.h>
#endif BSD
#ifdef SYSV
#include <ulimit.h>
#endif SYSV
/******************************* EXPORTS ******************************/
size_t real_maxpage;
size_t new_holepage;
char type_map[MAXPAGE];
struct typemanager tm_table[(int)t_end];
struct contblock *cb_pointer = NULL;
size_t ncb; /* number of contblocks */
size_t ncbpage; /* number of contblock pages */
size_t maxcbpage; /* maximum number of contblock pages */
size_t cbgccount; /* contblock gc count */
size_t holepage; /* hole pages */
char *heap_end; /* heap end */
char *heap_start; /* heap start */
char *data_end; /* end of data space */
/******************************* ------- ******************************/
#define SIGINTENTRY 6
static bool ignore_maximum_pages = TRUE;
#ifdef unix
# ifdef __MACH__
# define sbrk my_sbrk
# endif
extern void *sbrk(int);
#endif unix
#ifdef NEED_MALLOC
static cl_object malloc_list;
#endif
/*
Allocates n pages starting at heap end, without worring about the
hole. Basically just get the space from the Operating System.
*/
void
resize_hole(size_t n)
{
char *e;
size_t m;
m = (data_end - heap_end)/LISP_PAGESIZE;
if (n <= m)
return;
/* Create the hole */
#ifdef unix
e = sbrk(0);
if (data_end == e)
n -= m;
else {
dealloc(heap_end, data_end - heap_end);
/* FIXME! Horrible hack! */
/* mark as t_other pages not allocated by us */
heap_end = e;
while (data_end < heap_end) {
type_map[page(data_end)] = t_other;
data_end += LISP_PAGESIZE;
}
holepage = 0;
}
if ((int)sbrk(LISP_PAGESIZE * n) < 0)
error("Can't allocate. Good-bye!");
#endif unix
data_end += LISP_PAGESIZE*(n);
holepage += n;
}
/* Allocates n pages from the hole. */
void *
alloc_page(size_t n)
{
char *e = heap_end;
if (n >= holepage) {
gc(t_contiguous);
resize_hole(new_holepage+n);
}
holepage -= n;
heap_end += LISP_PAGESIZE*n;
return e;
}
static void
add_page_to_freelist(char *p, struct typemanager *tm)
{ enum type t;
cl_object x, f;
size_t i;
t = tm->tm_type;
type_map[page(p)] = t;
f = tm->tm_free;
for (i = tm->tm_nppage; i > 0; --i, p += tm->tm_size) {
x = (cl_object)p;
((struct freelist *)x)->t = (short)t;
((struct freelist *)x)->m = FREE;
((struct freelist *)x)->f_link = f;
f = x;
}
tm->tm_free = f;
tm->tm_nfree += tm->tm_nppage;
tm->tm_npage++;
}
cl_object
alloc_object(enum type t)
{
register cl_object obj;
register struct typemanager *tm;
register char *p;
switch (t) {
case t_fixnum:
return MAKE_FIXNUM(0); /* Immediate fixnum */
case t_character:
return code_char(' '); /* Immediate character */
default:
}
start_critical_section();
ONCE_MORE:
tm = tm_of(t);
if (interrupt_flag) {
interrupt_flag = FALSE;
#ifdef unix
alarm(0);
#endif unix
terminal_interrupt(TRUE);
}
obj = tm->tm_free;
if (obj == OBJNULL) {
size_t available = available_pages();
if (tm->tm_npage >= tm->tm_maxpage)
goto CALL_GC;
if (available < 1) {
ignore_maximum_pages = FALSE;
goto CALL_GC;
}
p = alloc_page(1);
add_page_to_freelist(p, tm);
obj = tm->tm_free;
/* why this? Beppe
if (tm->tm_npage >= tm->tm_maxpage)
goto CALL_GC; */
}
tm->tm_free = ((struct freelist *)obj)->f_link;
--(tm->tm_nfree);
(tm->tm_nused)++;
obj->d.t = (short)t;
obj->d.m = FALSE;
/* Now initialize the object so that it can be correctly marked
* by the GC
*/
switch (t) {
case t_bignum:
obj->big.big_dim = obj->big.big_size = 0;
obj->big.big_limbs = NULL;
break;
case t_ratio:
obj->ratio.num = OBJNULL;
obj->ratio.den = OBJNULL;
break;
case t_shortfloat:
case t_longfloat:
break;
case t_complex:
obj->complex.imag = OBJNULL;
obj->complex.real = OBJNULL;
break;
case t_symbol:
obj->symbol.plist = OBJNULL;
SYM_FUN(obj) = OBJNULL;
SYM_VAL(obj) = OBJNULL;
obj->symbol.name = OBJNULL;
break;
case t_package:
obj->pack.name = OBJNULL;
obj->pack.nicknames = OBJNULL;
obj->pack.shadowings = OBJNULL;
obj->pack.uses = OBJNULL;
obj->pack.usedby = OBJNULL;
obj->pack.internal = OBJNULL;
obj->pack.external = OBJNULL;
break;
case t_cons:
CAR(obj) = OBJNULL;
CDR(obj) = OBJNULL;
break;
case t_hashtable:
obj->hash.rehash_size = OBJNULL;
obj->hash.threshold = OBJNULL;
obj->hash.data = NULL;
break;
case t_array:
obj->array.displaced = Cnil;
obj->array.elttype = (short)aet_object;
obj->array.self.t = NULL;
break;
case t_vector:
obj->array.displaced = Cnil;
obj->array.elttype = (short)aet_object;
obj->array.self.t = NULL;
break;
case t_string:
obj->string.displaced = Cnil;
obj->string.self = NULL;
break;
case t_bitvector:
obj->vector.displaced = Cnil;
obj->vector.self.bit = NULL;
break;
#ifndef CLOS
case t_structure:
obj->str.name = OBJNULL;
obj->str.self = NULL;
break;
#endif CLOS
case t_stream:
obj->stream.mode = (short)smm_closed;
obj->stream.file = NULL;
obj->stream.object0 = OBJNULL;
obj->stream.object1 = OBJNULL;
obj->stream.buffer = NULL;
break;
case t_random:
break;
case t_readtable:
obj->readtable.table = NULL;
break;
case t_pathname:
obj->pathname.host = OBJNULL;
obj->pathname.device = OBJNULL;
obj->pathname.directory = OBJNULL;
obj->pathname.name = OBJNULL;
obj->pathname.type = OBJNULL;
obj->pathname.version = OBJNULL;
break;
case t_bytecodes:
obj->bytecodes.lex = Cnil;
obj->bytecodes.size = 0;
obj->bytecodes.data = NULL;
break;
case t_cfun:
obj->cfun.name = OBJNULL;
obj->cfun.block = NULL;
break;
case t_cclosure:
obj->cclosure.env = OBJNULL;
obj->cclosure.block = NULL;
break;
/*
case t_spice:
break;
*/
#ifdef THREADS
case t_cont:
obj->cn.cn_thread = OBJNULL;
break;
case t_thread:
obj->thread.entry = OBJNULL;
break;
#endif
#ifdef CLOS
case t_instance:
obj->instance.class = OBJNULL;
obj->instance.slots = NULL;
break;
case t_gfun:
obj->gfun.name = OBJNULL;
obj->gfun.method_hash = OBJNULL;
obj->gfun.instance = OBJNULL;
obj->gfun.specializers = NULL;
break;
#endif CLOS
case t_codeblock:
obj->cblock.name = Cnil;
obj->cblock.start = NULL;
obj->cblock.size = 0;
obj->cblock.data = NULL;
obj->cblock.data_size = 0;
obj->cblock.data_text = NULL;
obj->cblock.data_text_size = 0;
break;
default:
printf("\ttype = %d\n", t);
error("alloc botch.");
}
#ifdef THREADS
clwp->lwp_alloc_temporary = obj;
#endif THREADS
end_critical_section();
return(obj);
CALL_GC:
gc(tm->tm_type);
if (tm->tm_nfree != 0 &&
(float)tm->tm_nfree * 10.0 >= (float)tm->tm_nused)
goto ONCE_MORE;
/* EXHAUSTED: */
if (ignore_maximum_pages) {
if (tm->tm_maxpage/2 <= 0)
tm->tm_maxpage += 1;
else
tm->tm_maxpage += tm->tm_maxpage/2;
goto ONCE_MORE;
}
GC_disable();
{ cl_object s = make_simple_string(tm_table[(int)t].tm_name+1);
GC_enable();
CEerror("The storage for ~A is exhausted.~%\
Currently, ~D pages are allocated.~%\
Use ALLOCATE to expand the space.",
2, s, MAKE_FIXNUM(tm->tm_npage));
}
goto ONCE_MORE;
}
cl_object
make_cons(cl_object a, cl_object d)
{
register cl_object obj;
register char *p;
struct typemanager *tm=(&tm_table[(int)t_cons]);
start_critical_section();
ONCE_MORE:
if (interrupt_flag) {
interrupt_flag = FALSE;
#ifdef unix
alarm(0);
#endif unix
terminal_interrupt(TRUE);
}
obj = tm->tm_free;
if (obj == OBJNULL) {
if (tm->tm_npage >= tm->tm_maxpage)
goto CALL_GC;
if (available_pages() < 1) {
ignore_maximum_pages = FALSE;
goto CALL_GC;
}
p = alloc_page(1);
add_page_to_freelist(p,tm);
obj = tm->tm_free;
if (tm->tm_npage >= tm->tm_maxpage)
goto CALL_GC;
}
tm->tm_free = ((struct freelist *)obj)->f_link;
--(tm->tm_nfree);
(tm->tm_nused)++;
obj->d.t = (short)t_cons;
obj->d.m = FALSE;
CAR(obj) = a;
CDR(obj) = d;
end_critical_section();
return(obj);
CALL_GC:
gc(t_cons);
if ((tm->tm_nfree != 0) && (tm->tm_nfree * 10.0 >= tm->tm_nused))
goto ONCE_MORE;
/* EXHAUSTED: */
if (ignore_maximum_pages) {
if (tm->tm_maxpage/2 <= 0)
tm->tm_maxpage += 1;
else
tm->tm_maxpage += tm->tm_maxpage/2;
goto ONCE_MORE;
}
CEerror("The storage for CONS is exhausted.~%\
Currently, ~D pages are allocated.~%\
Use ALLOCATE to expand the space.",
1, MAKE_FIXNUM(tm->tm_npage));
goto ONCE_MORE;
#undef tm
}
cl_object
alloc_instance(cl_index slots)
{
cl_object i = alloc_object(t_instance);
/* INV: slots > 0 */
i->instance.slots = alloc(sizeof(cl_object) * slots);
i->instance.length = slots;
return i;
}
void *
alloc(size_t n)
{
register char *p;
register struct contblock **cbpp;
register size_t i;
register size_t m;
register bool g;
bool gg;
g = FALSE;
n = round_up(n);
start_critical_section();
ONCE_MORE:
if (interrupt_flag) {
interrupt_flag = FALSE;
gg = g;
terminal_interrupt(TRUE);
g = gg;
}
/* Use extra indirection so that cb_pointer can be updated */
for (cbpp = &cb_pointer; (*cbpp) != NULL; cbpp = &(*cbpp)->cb_link)
if ((*cbpp)->cb_size >= n) {
p = (char *)(*cbpp);
i = (*cbpp)->cb_size - n;
*cbpp = (*cbpp)->cb_link;
--ncb;
dealloc(p+n, i);
end_critical_section();
return(p);
}
m = round_to_page(n);
if (ncbpage + m > maxcbpage || available_pages() < m) {
if (available_pages() < m)
ignore_maximum_pages = FALSE;
if (!g) {
gc(t_contiguous);
g = TRUE;
goto ONCE_MORE;
}
if (ignore_maximum_pages) {
if (maxcbpage/2 <= 0)
maxcbpage += 1;
else
maxcbpage += maxcbpage/2;
g = FALSE;
goto ONCE_MORE;
}
CEerror("Contiguous blocks exhausted.~%\
Currently, ~D pages are allocated.~%\
Use ALLOCATE-CONTIGUOUS-PAGES to expand the space.",
1, MAKE_FIXNUM(ncbpage));
g = FALSE;
goto ONCE_MORE;
}
p = alloc_page(m);
for (i = 0; i < m; i++)
type_map[page(p) + i] = (char)t_contiguous;
ncbpage += m;
dealloc(p+n, LISP_PAGESIZE*m - n);
end_critical_section();
return(p);
}
/*
* adds a contblock to the list of available ones, pointed by cb_pointer,
* sorted by increasing size.
*/
void
dealloc(void *p, size_t s)
{
struct contblock **cbpp, *cbp;
if (s < CBMINSIZE)
return;
ncb++;
cbp = (struct contblock *)p;
cbp->cb_size = s;
for (cbpp = &cb_pointer; *cbpp != NULL; cbpp = &((*cbpp)->cb_link))
if ((*cbpp)->cb_size >= s) {
cbp->cb_link = *cbpp;
*cbpp = cbp;
return;
}
cbp->cb_link = NULL;
*cbpp = cbp;
}
/*
* align must be a power of 2 representing the alignment boundary
* required for the block.
*/
void *
alloc_align(size_t size, size_t align)
{
void *output;
start_critical_section();
align--;
output = (void*)(((cl_fixnum)alloc(size + align) + align - 1) & ~align)
end_critical_section();
return output;
}
static void
init_tm(enum type t, char *name, size_t elsize, size_t maxpage)
{
int i, j;
struct typemanager *tm = &tm_table[(int)t];
tm->tm_name = name;
for (i = (int)t_start, j = i-1; i < (int)t_end; i++)
if (tm_table[i].tm_size >= elsize &&
(j < (int)t_start || tm_table[j].tm_size > tm_table[i].tm_size))
j = i;
if (j >= (int)t_start) {
tm->tm_type = (enum type)j;
tm_table[j].tm_maxpage += maxpage;
return;
}
tm->tm_type = t;
tm->tm_size = round_up(elsize);
tm->tm_nppage = LISP_PAGESIZE/round_up(elsize);
tm->tm_free = OBJNULL;
tm->tm_nfree = 0;
tm->tm_nused = 0;
tm->tm_npage = 0;
tm->tm_maxpage = maxpage;
tm->tm_gccount = 0;
}
static int alloc_initialized = FALSE;
void
init_alloc(void)
{
cl_index i;
if (alloc_initialized) return;
alloc_initialized = TRUE;
holepage = 0;
new_holepage = HOLEPAGE;
#ifdef MSDOS
real_maxpage = MAXPAGE;
#elif defined(BSD)
{
struct rlimit data_rlimit;
# ifdef __MACH__
extern int mach_maplimit;
sbrk(0);
real_maxpage = mach_maplimit/LISP_PAGESIZE;
/* alternative
getrlimit(RLIMIT_DATA, &data_rlimit);
real_maxpage = ((unsigned)get_etext() +
(unsigned)data_rlimit.rlim_cur)/LISP_PAGESIZE;
*/
# else
extern etext;
getrlimit(RLIMIT_DATA, &data_rlimit);
real_maxpage = ((unsigned int)&etext +
(unsigned)data_rlimit.rlim_cur)/LISP_PAGESIZE;
# endif
if (real_maxpage > MAXPAGE) real_maxpage = MAXPAGE;
}
#elif defined(SYSV)
real_maxpage= ulimit(UL_GMEMLIM)/LISP_PAGESIZE;
if (real_maxpage > MAXPAGE) real_maxpage = MAXPAGE;
#endif MSDOS
#ifdef unix
heap_end = sbrk(0);
i = (int)heap_end & (LISP_PAGESIZE - 1);
if (i)
sbrk(LISP_PAGESIZE - i);
heap_end = heap_start = data_end = sbrk(0);
#else
#error "Non unix allocation scheme not defined"
#endif unix
resize_hole(INIT_HOLEPAGE);
for (i = 0; i < MAXPAGE; i++)
type_map[i] = (char)t_other;
/* Initialization must be done in increasing size order: */
init_tm(t_shortfloat, "FSHORT-FLOAT", /* 8 */
sizeof(struct shortfloat_struct), 1);
init_tm(t_cons, ".CONS", sizeof(struct cons), 384); /* 12 */
init_tm(t_longfloat, "LLONG-FLOAT", /* 16 */
sizeof(struct longfloat_struct), 1);
init_tm(t_bytecodes, "bBYTECODES", sizeof(struct bytecodes), 64);
init_tm(t_string, "\"STRING", sizeof(struct string), 64); /* 20 */
init_tm(t_array, "aARRAY", sizeof(struct array), 64); /* 24 */
init_tm(t_pathname, "pPATHNAME", sizeof(struct pathname), 1); /* 28 */
init_tm(t_symbol, "|SYMBOL", sizeof(struct symbol), 64); /* 32 */
init_tm(t_package, ":PACKAGE", sizeof(struct package), 1); /* 36 */
init_tm(t_codeblock, "#CODEBLOCK", sizeof(struct codeblock), 1);
init_tm(t_bignum, "BBIGNUM", sizeof(struct bignum), 16);
init_tm(t_ratio, "RRATIO", sizeof(struct ratio), 1);
init_tm(t_complex, "CCOMPLEX", sizeof(struct complex), 1);
init_tm(t_hashtable, "hHASH-TABLE", sizeof(struct hashtable), 1);
init_tm(t_vector, "vVECTOR", sizeof(struct vector), 2);
init_tm(t_bitvector, "bBIT-VECTOR", sizeof(struct vector), 1);
init_tm(t_stream, "sSTREAM", sizeof(struct stream), 1);
init_tm(t_random, "$RANDOM-STATE", sizeof(struct random), 1);
init_tm(t_readtable, "rREADTABLE", sizeof(struct readtable), 1);
init_tm(t_cfun, "fCFUN", sizeof(struct cfun), 32);
init_tm(t_cclosure, "cCCLOSURE", sizeof(struct cclosure), 1);
#ifndef CLOS
init_tm(t_structure, "SSTRUCTURE", sizeof(struct structure), 32);
#else
init_tm(t_instance, "IINSTANCE", sizeof(struct instance), 32);
init_tm(t_gfun, "GGFUN", sizeof(struct gfun), 32);
#endif CLOS
#ifdef THREADS
init_tm(t_cont, "?CONT", sizeof(struct cont), 2);
init_tm(t_thread, "tTHREAD", sizeof(struct thread), 2);
#endif THREADS
ncb = 0;
ncbpage = 0;
#ifdef THREADS
maxcbpage = 2048;
#else
maxcbpage = 512;
#endif THREADS
#ifdef NEED_MALLOC
malloc_list = Cnil;
register_root(&malloc_list);
#endif
}
static int
t_from_type(cl_object type)
{ int t;
type = coerce_to_string(type);
for (t = (int)t_start ; t < (int)t_end ; t++) {
struct typemanager *tm = &tm_table[t];
if (tm->tm_name &&
strncmp((tm->tm_name)+1, type->string.self, type->string.fillp) == 0)
return(t);
}
FEerror("Unrecognized type", 0);
}
@(defun si::allocate (type qty &optional (now Cnil))
struct typemanager *tm;
char *pp;
size_t i;
@
tm = tm_of(t_from_type(type));
i = fixnnint(qty);
if (tm->tm_npage > i) i = tm->tm_npage;
tm->tm_maxpage = i;
if (now == Cnil || tm->tm_maxpage <= tm->tm_npage)
@(return Ct)
if (available_pages() < tm->tm_maxpage - tm->tm_npage ||
(pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL)
FEerror("Can't allocate ~D pages for ~A.", 2, type,
make_simple_string(tm->tm_name+1));
for (; tm->tm_npage < tm->tm_maxpage; pp += LISP_PAGESIZE)
add_page_to_freelist(pp, tm);
@(return Ct)
@)
@(defun si::maxpage (type)
@
@(return MAKE_FIXNUM(tm_of(t_from_type(type))->tm_maxpage))
@)
@(defun si::allocated_pages (type)
@
@(return MAKE_FIXNUM(tm_of(t_from_type(type))->tm_npage))
@)
@(defun si::alloc_contpage (qty &optional (now Cnil))
size_t i, m;
char *p;
@
i = fixnnint(qty);
if (ncbpage > i)
FEerror("Can't set the limit for contiguous blocks to ~D,~%\
since ~D pages are already allocated.",
2, qty, MAKE_FIXNUM(ncbpage));
maxcbpage = i;
if (Null(now))
@(return Ct)
m = maxcbpage - ncbpage;
if (available_pages() < m || (p = alloc_page(m)) == NULL)
FEerror("Can't allocate ~D pages for contiguous blocks.",
1, qty);
for (i = 0; i < m; i++)
type_map[page(p + LISP_PAGESIZE*i)] = (char)t_contiguous;
ncbpage += m;
dealloc(p, LISP_PAGESIZE*m);
@(return Ct)
@)
@(defun si::ncbpage ()
@
@(return MAKE_FIXNUM(ncbpage))
@)
@(defun si::maxcbpage ()
@
@(return MAKE_FIXNUM(maxcbpage))
@)
@(defun si::get_hole_size ()
@
@(return MAKE_FIXNUM(new_holepage))
@)
@(defun si::set_hole_size (size)
size_t i;
@
i = fixnnint(size);
if (i == 0 || i > available_pages() + new_holepage)
FEerror("Illegal value for the hole size.", 0);
new_holepage = i;
@(return size)
@)
@(defun si::ignore_maximum_pages (&optional (flag OBJNULL))
@
if (flag == OBJNULL)
@(return (ignore_maximum_pages? Ct : Cnil))
ignore_maximum_pages = Null(flag);
@(return flag)
@)
static cl_object siVlisp_maxpages, siClisp_pagesize;
void
init_alloc_function(void)
{
ignore_maximum_pages = TRUE;
siVlisp_maxpages = make_si_special("*LISP-MAXPAGES*", MAKE_FIXNUM(real_maxpage));
siClisp_pagesize = make_si_constant("LISP-PAGESIZE", MAKE_FIXNUM(LISP_PAGESIZE));
SYM_VAL(siVlisp_maxpages) = MAKE_FIXNUM(real_maxpage);
}
#ifdef NEED_MALLOC
/*
UNIX malloc simulator.
Used by
getwd, popen, etc.
*/
#undef malloc
#undef calloc
#undef free
#undef cfree
#undef realloc
void *
malloc(size_t size)
{
cl_object x;
#ifdef __GNUC__
if (!GC_enabled() && !alloc_initialized)
init_alloc();
#endif __GNUC__
x = alloc_simple_string(size-1);
x->string.self = alloc(size);
malloc_list = make_cons(x, malloc_list);
return(x->string.self);
}
void
free(void *ptr)
{
cl_object *p;
if (ptr) {
for (p = &malloc_list; !endp(*p); p = &(CDR((*p))))
if ((CAR((*p)))->string.self == ptr) {
dealloc(CAR((*p))->string.self, CAR((*p))->string.dim);
CAR((*p))->string.self = NULL;
*p = CDR((*p));
return;
}
FEerror("free(3) error.", 0);
}
}
void *
realloc(void *ptr, size_t size)
{
cl_object x;
size_t i, j;
for (x = malloc_list; !endp(x); x = CDR(x))
if (CAR(x)->string.self == ptr) {
x = CAR(x);
if (x->string.dim >= size) {
x->string.fillp = size;
return(ptr);
} else {
j = x->string.dim;
x->string.self = alloc(size);
x->string.fillp = x->string.dim = size;
memcpy(x->string.self, ptr, j);
dealloc(ptr, j);
return(x->string.self);
}
}
FEerror("realloc(3) error.", 0);
}
void *
calloc(size_t nelem, size_t elsize)
{
char *ptr;
size_t i = nelem*elsize;
ptr = malloc(i);
memset(ptr, 0 , i);
return(ptr);
}
void cfree(void *ptr)
{
free(ptr);
}
/* make f allocate enough extra, so that we can round
up, the address given to an even multiple. Special
case of size == 0 , in which case we just want an aligned
number in the address range
*/
#define ALLOC_ALIGNED(f, size, align) \
((align) <= 4 ? (int)(f)(size) : \
((align) * (((unsigned)(f)(size + (size ? (align) - 1 : 0)) + (align) - 1)/(align))))
void *
memalign(size_t align, size_t size)
{ cl_object x = alloc_simple_string(size);
x->string.self = (char *)ALLOC_ALIGNED(alloc, size, align);
malloc_list = make_cons(x, malloc_list);
return x->string.self;
}
# ifdef WANT_VALLOC
char *
valloc(size_t size)
{ return memalign(getpagesize(), size);}
# endif WANT_VALLOC
#endif NEED_MALLOC

Some files were not shown because too many files have changed in this diff Show more