#include "fmt.h"
#define T Text_T
typedef struct T {
int len;
const char *str;
} T;
typedef struct Text_save_T *Text_save_T;
extern const T Text_cset;
extern const T Text_ascii;
extern const T Text_ucase;
extern const T Text_lcase;
extern const T Text_digits;
extern const T Text_null;
extern T Text_put(const char *str);
extern char *Text_get(char *str, int size, T s);
extern T Text_box(const char *str, int len);
extern T Text_sub(T s, int i, int j);
extern int Text_pos(T s, int i);
extern T Text_cat (T s1, T s2);
extern T Text_dup (T s, int n);
extern T Text_reverse(T s);
extern T Text_map(T s, const T *from, const T *to);
extern int Text_cmp(T s1, T s2);
extern int Text_chr (T s, int i, int j, int c);
extern int Text_rchr (T s, int i, int j, int c);
extern int Text_upto (T s, int i, int j, T set);
extern int Text_rupto(T s, int i, int j, T set);
extern int Text_any (T s, int i, T set);
extern int Text_many (T s, int i, int j, T set);
extern int Text_rmany(T s, int i, int j, T set);
extern int Text_find (T s, int i, int j, T str);
extern int Text_rfind (T s, int i, int j, T str);
extern int Text_match (T s, int i, int j, T str);
extern int Text_rmatch(T s, int i, int j, T str);
extern void Text_fmt(int code, va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision);
extern Text_save_T Text_save(void);
extern void Text_restore(Text_save_T *save);
#undef T
#endif
eisl-5.55/cii/include/thread.h 0000664 0000000 0000000 00000000756 15066676224 0016241 0 ustar 00root root 0000000 0000000 /* $Id$ */
#ifndef THREAD_INCLUDED
#define THREAD_INCLUDED
#include "except.h"
#define T Thread_T
typedef struct T *T;
extern const Except_T Thread_Failed;
extern const Except_T Thread_Alerted;
extern int Thread_init (int preempt, ...);
extern T Thread_new (int apply(void *),
void *args, int nbytes, ...);
extern void Thread_exit (int code);
extern void Thread_alert(T t);
extern T Thread_self (void);
extern int Thread_join (T t);
extern void Thread_pause(void);
#undef T
#endif
eisl-5.55/cii/include/xp.h 0000664 0000000 0000000 00000002000 15066676224 0015401 0 ustar 00root root 0000000 0000000 /* $Id$ */
#ifndef XP_INCLUDED
#define XP_INCLUDED
#define T XP_T
typedef unsigned char *T;
extern int XP_add(int n, T z, T x, T y, int carry);
extern int XP_sub(int n, T z, T x, T y, int borrow);
extern int XP_mul(T z, int n, T x, int m, T y);
extern int XP_div(int n, T q, T x, int m, T y, T r,T tmp);
extern int XP_sum (int n, T z, T x, int y);
extern int XP_diff (int n, T z, T x, int y);
extern int XP_product (int n, T z, T x, int y);
extern int XP_quotient(int n, T z, T x, int y);
extern int XP_neg(int n, T z, T x, int carry);
extern int XP_cmp(int n, T x, T y);
extern void XP_lshift(int n, T z, int m, T x,
int s, int fill);
extern void XP_rshift(int n, T z, int m, T x,
int s, int fill);
extern int XP_length (int n, T x);
extern unsigned long XP_fromint(int n, T z,
unsigned long u);
extern unsigned long XP_toint (int n, T x);
extern int XP_fromstr(int n, T z, const char *str,
int base, char **end);
extern char *XP_tostr (char *str, int size, int base,
int n, T x);
#undef T
#endif
eisl-5.55/cii/install.html 0000664 0000000 0000000 00000040567 15066676224 0015536 0 ustar 00root root 0000000 0000000
CII Installation Guide
CII Installation Guide
David R. Hanson,
Google
Contents
Introduction
Installation on UNIX
Installation on Windows 95/NT
Reporting Bugs
This page describes how to install the software from my book C Interfaces and Implementations:
Techniques for Creating Reusable Software (Addison-Wesley Professional
Computing Series, 1997, ISBN 0-201-49841-3). A CII distribution includes the following
files and directories.
The CII distributions are numbered X.Y where X is the major release
number and Y is the minor release number. Starting with major release 1, minor
releases fix bugs and perhaps make improvements, but do not change
interfaces. The interfaces and the compiled library are compatible with earlier and later
minor releases; for example, a program compiled with the 1.3 release is compatible with
release 1.8 and vice versa. Major releases occur when one or more interfaces are changed
or extended, or when new interfaces are added.
It's usually best to follow a similar naming scheme when installing CII so that
programs compiled with one major release can be recompiled even after a subsequent major
release has been installed. The minor release number can be omitted. On UNIX, for example,
this convention can be accomplished by installing the interfaces in, say, /usr/local/lib/cii/X/include,
where X is the major release number, and installing the library, libcii.a,
in /usr/local/lib/cii/X/libcii.a.
At UNIX sites with multiple platforms (architectures and OSes) and a single /usr/local
hierarchy, the library can be installed in a platform-specific location below /usr/local/cii/X,
e.g., /usr/local/lib/cii/X/alpha-osf/libcii.a. The
interfaces are machine independent and thus don't need platform-specific locations.
Similar conventions can be used on Windows 95/NT.
Following this scheme permits the actual installation locations to be confined to
specifying prefixes, like /usr/local/lib/cii/X/include
and /usr/local/lib/cii/X/, in makefiles; programs can
include interfaces by giving just the names of their header files.
On UNIX systems, it's also useful to plant release-independent symbol link to the
latest CII release, e.g., make /usr/local/include/cii point to /usr/local/lib/cii/X/include
and /usr/local/lib/libcii.a point to /usr/local/lib/cii/X/libcii.a.
NB: If you use several compilers, you may need compiler-specific
variants of libcii.a, and thus use platform names that denote a specific
architecture, OS, and compiler. For example, the Text interface uses
small structures and passes them by value, and, on some platforms, one C compiler might
generate code for src/text.c that is incompatible with another compiler. This
problem is not specific to CII; it can occur with any library.
The installation makefile is designed so that CII can be installed from a read-only
file system or directory, which is common in networked environments, so the distribution
can be unloaded on a central file server. If you're installing CII on a UNIX system,
continue with the next section. If you're installing CII on a Windows NT 4.0 or Windows 95
system, read the next section first, then follow the Windows NT/95
instructions.
The CII components (include files and the library) are installed in a single build
directory. On multi-platform systems supported by a central file server, it's common
to store the build directory in a location specific to the platform and to the version of
CII, as suggested above. For example, installation on a UNIX system involves the following
steps. Below, the build directory is referred to as BUILDDIR, and the
commands shown assume the distribution directory is the current working directory.
If you want to build in the distribution directory, leave BUILDDIR
undefined and start at step 3.
- Create the build directory, using a version- and platform-specific naming convention as
suggested above, and record the name of this directory in the
BUILDDIR
environment variable:
% setenv BUILDDIR /usr/local/lib/cii/1/alpha-osf/
% mkdir -p $BUILDDIR
The trailing slash is required, because BUILDDIR is concatenated
with file names in the makefile, e.g., $(BUILDDIR)atom$O.
Here and below, commands assume the C shell. Also, you'll need a version of mkdir
that supports the -p option, which creates intermediate directories as
necessary, or create them with individual mkdir commands.
- Create the include directory in the build directory, and copy the include files:
% mkdir ${BUILDDIR}include
% cp -p include/*.h ${BUILDDIR}include
Some users create a symbolic link to the include directory in the distribution instead
of making repeated copies of the include files. For example, at Princeton, the
distributions are stored under /proj/pkg/cii, so the include files are
"installed" by creating one symbolic link:
% ln -s /proj/pkg/cii/1.1/include ${BUILDDIR}include
- Build everything using the appropriate make command for your environment:
| ALPHA OSF/1 V3.2A |
% make CC='cc -std1 -Dalpha' AS='as -Dalpha' |
| MIPS IRIX 6.2 |
% make |
| MIPS Ultrix 4.3 |
% gmake CC=gcc LD=gcc |
| SPARC SunOS 5.5.1 (Solaris) |
% make -k CC='cc -DMAXALIGN=8' THREADS= |
| X86_32 Linux |
% make CC='cc -DMAXALIGN=4' AS='cc -c -x assembler-with-cpp -traditional' |
| X86_64 Linux, Apple Intel Mac OS X 10.5.x |
% make -k THREADS= |
This command builds, in BUILDDIR, libcii.a, memchk.o,
and the examples. There may be some warnings on some platforms. The assignment THREADS=
appears on those platforms for which there is no Thread implementation. On these
platforms, examples that use Thread won't link correctly, so use the -k
option so make keeps going.
On most platforms, malloc returns pointers to
blocks that are aligned on addresses that are multiples of the size of the largest basic
data type. Some CII functions use a union to determine this multiple (cf. union align
on p. 80). Alignments are less restrictive on some platforms and, for these, MAXALIGN
must be defined as the alignment required as shown above. maxalign.c
is a C program that attempts to determine the correct value for MAXALIGN, if
one is necessary, and echo the appropriate -D option. The
method used relies on the C compiler using the same alignments as malloc,
which is not required. malloc is the final authority: If it returns addresses
that are multiples of sizeof (union align),
then MAXALIGN is unnecessary; otherwise, MAXALIGN must provide
the alignment.
So, maxalign.c calls malloc(1) to determine if the address it returns
has an alignment less strict than that used by the C compiler.
The command make maxalign
compiles and executes maxalign.c; the output shows the appropriate -D option,
if one is needed.
Incorrect values of MAXALIGN can cause crashes and assertion
failures.
src/{memcmp,memmove,strncmp}.c are implementations of the similarly named
ANSI library functions. These are included in the distribution because some of them are
implemented incorrectly on some UNIX platforms. The corresponding object files are
assigned to EXTRAS; if some of these functions are implemented correctly on
your system, you can omit the CII versions by either editing libcii.a, or
including the appropriate assignment to EXTRAS, e.g.,
% make EXTRAS=${BUILDDIR}memcmp.o
- The
makefile includes the file named by the CUSTOM
macro; the default is custom.mk, and an empty custom.mk is
included in the distribution. If desired, prepare a site-specific customization file and
define CUSTOM to the path of that file when invoking make in the previous
step. For example, on the ALPHA, I use osf.mk:
% cat osf.mk
BUILDDIR=/usr/local/lib/cii/1/alpha-osf/
CC=cc -std1 -Dalpha
AS=as -Dalpha
% make CUSTOM=osf.mk
- Run a few of the test programs, e.g.,
% ${BUILDDIR}wf <makefile
% ${BUILDDIR}cref src/fmt.c src/str.c
and then clean up:
% make clean
This command removes everything except include and libcii.a.
If you want to leave memchk.o installed, rebuild it, e.g.,
% make ${BUILDDIR}memchk.o
memchk.c uses MAXALIGN, so if you defined MAXALIGN
when building libcii.a, include it when rebuilding memchk.o,
e.g.,
% make CC='cc -DMAXALIGN=8' ${BUILDDIR}memchk.o
make clobber removes everything from BUILDDIR.
- If desired, plant release-independent symbolic links to the include directory and to the
installed library, e.g.,
% ln -s ${BUILDDIR}include /usr/local/include/cii
% ln -s ${BUILDDIR}libcii.a /usr/local/lib/libcii.a
On Windows NT or Windows 95, you can use a directory organization similar to the one
described above for UNIX as follows. The commands below assume the distribution is rooted
at C:\dist and that the C compiler is Microsoft Visual C/C++ 5.0.
- Create the build directory and set
BUILDDIR:
C:\dist>set BUILDDIR=\lib\cii\1
C:\dist>mkdir %BUILDDIR%
Change the assignment to BUILDDIR to suit your local conventions.
On Windows, BUILDDIR must not include the trailing backslash.
- Create the include directory in the build directory, and copy the include files:
C:\dist>mkdir %BUILDDIR%\include
C:\dist>copy include\*.h %BUILDDIR%\include
- Build everything using
nmake:
C:\dist>nmake -f makefile.nt BUILDDIR=%BUILDDIR%
This command builds, in BUILDDIR, libcii.lib, libcii.pdb,
memchk.obj, and the examples. The default BUILDDIR is \lib\cii\1,
so the assignment to BUILDDIR above can be omitted if you use this default.
- Run a few of the test programs, e.g.,
C:\dist>%BUILDDIR%\wf <makefile
C:\dist>%BUILDDIR%\sieve
and then clean up:
C:\dist>nmake -f makefile.nt BUILDDIR=%BUILDDIR% clean
This command removes everything except include, libcii.a, and
libcii.pdb. If you want to leave memchk.obj installed, rebuild
it, e.g.,
C:\dist>nmake -f makefile.nt BUILDDIR=%BUILDDIR% %BUILDDIR%\memchk.obj
make clobber removes everything from BUILDDIR
src\libcii.def is a module definition file for the CII library. To create a
DLL instead of a statically linked library, execute
C:\dist>nmake -f makefile.nt BUILDDIR=%BUILDDIR% libcii.dll
This command creates %BUILDDIR%\libcii.dll, overwrites %BUILDDIR%\libcii.lib
with the import library, and creates the export library %BUILDDIR%\libcii.exp.
If you use libcii.dll, you'll need to move it to a directory on your PATH.
Some users copy the include and library files into their Visual C/C++ 5.0 distribution,
e.g.,
C:\dist>mkdir "\Program Files\DevStudio\VC\include\cii"
C:\dist>copy include\*.h "\Program Files\DevStudio\VC\include\cii"
C:\dist>copy %BUILDDIR%\libcii.* "\Program Files\DevStudio\VC\lib"
Devise the shortest possible example program that elicits the bug. Prune your example
until it can be pruned no more without sending the error into hiding. I prune most error
demonstrations to only a few lines. Annotate your example with C comments that describe
the bug and your suggested fix, if you have one. If the example crashes, please report the
last part of the call chain if you can.
Send your example by electronic mail to me (see below).
Please send only valid C programs; put all remarks in C comments so that I can process
reports semi-automatically.
David Hanson
eisl-5.55/cii/makefile 0000664 0000000 0000000 00000015377 15066676224 0014703 0 ustar 00root root 0000000 0000000 # $Id$
MAJORVERSION=2
A=.a
O=.o
SO=.so
E=
CC=cc
I=include
CFLAGS=-g -I$I
LDFLAGS=-g
LD=cc
AS=as
AR=ar ruv
RANLIB=ranlib
DIFF=diff
RM=rm -f
CUSTOM=custom.mk
EXTRAS=$(BUILDDIR)memcmp$O $(BUILDDIR)memmove$O $(BUILDDIR)strncmp$O
THREADS=$(BUILDDIR)thread$O $(BUILDDIR)swtch$O $(BUILDDIR)chan$O
include $(CUSTOM)
B=$(BUILDDIR)
OBJS= $Bap$O \
$Barena$O \
$Barith$O \
$Barray$O \
$Bassert$O \
$Batom$O \
$Bbit$O \
$Bexcept$O \
$Bfmt$O \
$Blist$O \
$Bmem$O \
$Bmp$O \
$Bring$O \
$Bseq$O \
$Bset$O \
$Bstack$O \
$Bstr$O \
$Btable$O \
$Btext$O \
$Bxp$O \
$(THREADS)
EXAMPLES= $Bdouble$E \
$Bcalc$E \
$Bids$E \
$Bmpcalc$E \
$Bwf$E \
$Bxref$E \
$Bcref$E \
$Biref$E \
$Bkref$E \
$Bidents$E \
$Bwords$E \
$Bbasename$E \
$Bdirname$E \
$Bsort$E \
$Bspin$E \
$Bsieve$E
all:: $Blibcii$A $(EXAMPLES) $Bmemchk$O
$Blibcii$A:: $(OBJS) $(EXTRAS)
$(AR) $@ $(OBJS) $(EXTRAS); $(RANLIB) $@ || true
# Linux-specific rule for building a shared library
$Blibcii$(SO).$(MAJORVERSION): $(OBJS) $(EXTRAS)
$(CC) -shared -Wl,-soname,libcii$(SO).$(MAJORVERSION) -o $@ $(OBJS) $(EXTRAS)
$Bap$O: src/ap.c; $(CC) $(CFLAGS) -c -o $@ src/ap.c
$Barena$O: src/arena.c; $(CC) $(CFLAGS) -c -o $@ src/arena.c
$Barith$O: src/arith.c; $(CC) $(CFLAGS) -c -o $@ src/arith.c
$Barray$O: src/array.c; $(CC) $(CFLAGS) -c -o $@ src/array.c
$Bassert$O: src/assert.c; $(CC) $(CFLAGS) -c -o $@ src/assert.c
$Batom$O: src/atom.c; $(CC) $(CFLAGS) -c -o $@ src/atom.c
$Bbit$O: src/bit.c; $(CC) $(CFLAGS) -c -o $@ src/bit.c
$Bchan$O: src/chan.c; $(CC) $(CFLAGS) -c -o $@ src/chan.c
$Bexcept$O: src/except.c; $(CC) $(CFLAGS) -c -o $@ src/except.c
$Bfmt$O: src/fmt.c; $(CC) $(CFLAGS) -c -o $@ src/fmt.c
$Blist$O: src/list.c; $(CC) $(CFLAGS) -c -o $@ src/list.c
$Bmem$O: src/mem.c; $(CC) $(CFLAGS) -c -o $@ src/mem.c
$Bmemchk$O: src/memchk.c; $(CC) $(CFLAGS) -c -o $@ src/memchk.c
$Bmp$O: src/mp.c; $(CC) $(CFLAGS) -c -o $@ src/mp.c
$Bring$O: src/ring.c; $(CC) $(CFLAGS) -c -o $@ src/ring.c
$Bseq$O: src/seq.c; $(CC) $(CFLAGS) -c -o $@ src/seq.c
$Bset$O: src/set.c; $(CC) $(CFLAGS) -c -o $@ src/set.c
$Bstack$O: src/stack.c; $(CC) $(CFLAGS) -c -o $@ src/stack.c
$Bstr$O: src/str.c; $(CC) $(CFLAGS) -c -o $@ src/str.c
$Btable$O: src/table.c; $(CC) $(CFLAGS) -c -o $@ src/table.c
$Btext$O: src/text.c; $(CC) $(CFLAGS) -c -o $@ src/text.c
$Bthread$O: src/thread.c; $(CC) $(CFLAGS) -c -o $@ src/thread.c
$Bthread-nt$O: src/thread-nt.c;$(CC) $(CFLAGS) -c -o $@ src/thread-nt.c
$Bxp$O: src/xp.c; $(CC) $(CFLAGS) -c -o $@ src/xp.c
$Bswtch$O: src/swtch.s; $(AS) -o $@ src/swtch.s
$Bmemcmp$O: src/memcmp.c; $(CC) $(CFLAGS) -c -o $@ src/memcmp.c
$Bmemmove$O: src/memmove.c; $(CC) $(CFLAGS) -c -o $@ src/memmove.c
$Bstrncmp$O: src/strncmp.c; $(CC) $(CFLAGS) -c -o $@ src/strncmp.c
$Bdouble$O: examples/double.c; $(CC) $(CFLAGS) -c -o $@ examples/double.c
$Bcalc$O: examples/calc.c; $(CC) $(CFLAGS) -c -o $@ examples/calc.c
$Bids$O: examples/ids.c; $(CC) $(CFLAGS) -c -o $@ examples/ids.c
$Bmpcalc$O: examples/mpcalc.c; $(CC) $(CFLAGS) -c -o $@ examples/mpcalc.c
$Biref$O: examples/iref.c; $(CC) $(CFLAGS) -c -o $@ examples/iref.c
$Bkref$O: examples/kref.c; $(CC) $(CFLAGS) -c -o $@ examples/kref.c
$Bidents$O: examples/idents.c; $(CC) $(CFLAGS) -c -o $@ examples/idents.c
$Bwords$O: examples/words.c; $(CC) $(CFLAGS) -c -o $@ examples/words.c
$Bbasename$O: examples/basename.c; $(CC) $(CFLAGS) -c -o $@ examples/basename.c
$Bwf$O: examples/wf.c; $(CC) $(CFLAGS) -c -o $@ examples/wf.c
$Bgetword$O: examples/getword.c; $(CC) $(CFLAGS) -c -o $@ examples/getword.c
$Bxref$O: examples/xref.c; $(CC) $(CFLAGS) -c -o $@ examples/xref.c
$Binteger$O: examples/integer.c; $(CC) $(CFLAGS) -c -o $@ examples/integer.c
$Bcref$O: examples/cref.c; $(CC) $(CFLAGS) -c -o $@ examples/cref.c
$Bsort$O: examples/sort.c; $(CC) $(CFLAGS) -c -o $@ examples/sort.c
$Bspin$O: examples/spin.c; $(CC) $(CFLAGS) -c -o $@ examples/spin.c
$Bsieve$O: examples/sieve.c; $(CC) $(CFLAGS) -c -o $@ examples/sieve.c
$Bwf$O $Bxref$O $Bgetword$O: examples/getword.h
$Bcref$O $Binteger$O: examples/integer.h
$Bdouble$E: $Bdouble$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bdouble$O $Blibcii$A
$Bcalc$E: $Bcalc$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bcalc$O $Blibcii$A
$Bids$E: $Bids$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bids$O $Blibcii$A
$Bmpcalc$E: $Bmpcalc$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bmpcalc$O $Blibcii$A
$Biref$E: $Biref$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Biref$O $Blibcii$A
$Bkref$E: $Bkref$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bkref$O $Blibcii$A
$Bidents$E: $Bidents$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bidents$O $Blibcii$A
$Bwords$E: $Bwords$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bwords$O $Blibcii$A
$Bbasename$E: $Bbasename$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bbasename$O $Blibcii$A
$Bdirname$E: $Bbasename$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bbasename$O $Blibcii$A
$Bwf$E: $Bwf$O $Bgetword$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bwf$O $Bgetword$O $Blibcii$A
$Bxref$E: $Bxref$O $Bgetword$O $Blibcii$A;$(LD) $(LDFLAGS) -o $@ $Bxref$O $Bgetword$O $Blibcii$A
$Bcref$E: $Bcref$O $Binteger$O $Blibcii$A;$(LD) $(LDFLAGS) -o $@ $Bcref$O $Binteger$O $Blibcii$A
$Bsort$E: $Bsort$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bsort$O $Blibcii$A
$Bspin$E: $Bspin$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bspin$O $Blibcii$A
$Bsieve$E: $Bsieve$O $Blibcii$A; $(LD) $(LDFLAGS) -o $@ $Bsieve$O $Blibcii$A
maxalign: $Bmaxalign$E
$Bmaxalign$E
$Bmaxalign$E: misc/maxalign.c
$(CC) -o $@ misc/maxalign.c
clean::
$(RM) $B*$O
$(RM) $(EXAMPLES)
clobber:: clean
$(RM) $Blibcii$A
# DO NOT DELETE THIS LINE -- make depend depends on it.
$Bap$O: $I/assert.h $I/except.h $I/ap.h $I/fmt.h $I/xp.h $I/mem.h
$Barena$O: $I/assert.h $I/except.h $I/arena.h
$Barith$O: $I/arith.h
$Barray$O: $I/assert.h $I/except.h $I/array.h $I/arrayrep.h $I/mem.h
$Bassert$O: $I/assert.h $I/except.h
$Batom$O: $I/atom.h $I/assert.h $I/except.h $I/mem.h
$Bbit$O: $I/assert.h $I/except.h $I/bit.h $I/mem.h
$Bchan$O: $I/assert.h $I/except.h $I/mem.h $I/chan.h $I/sem.h
$Bexcept$O: $I/assert.h $I/except.h
$Bfmt$O: $I/assert.h $I/except.h $I/fmt.h $I/mem.h
$Blist$O: $I/assert.h $I/except.h $I/mem.h $I/list.h
$Bmem$O: $I/assert.h $I/except.h $I/mem.h
$Bmemchk$O: $I/assert.h $I/except.h $I/mem.h
$Bmp$O: $I/assert.h $I/except.h $I/fmt.h $I/mem.h $I/xp.h $I/mp.h
$Bring$O: $I/assert.h $I/except.h $I/ring.h $I/mem.h
$Bseq$O: $I/assert.h $I/except.h $I/seq.h $I/array.h $I/arrayrep.h $I/mem.h
$Bset$O: $I/mem.h $I/except.h $I/assert.h $I/arith.h $I/set.h
$Bstack$O: $I/assert.h $I/except.h $I/mem.h $I/stack.h
$Bstr$O: $I/assert.h $I/except.h $I/fmt.h $I/str.h $I/mem.h
$Btable$O: $I/mem.h $I/except.h $I/assert.h $I/table.h
$Btext$O: $I/assert.h $I/except.h $I/fmt.h $I/text.h $I/mem.h
$Bthread$O: $I/assert.h $I/except.h $I/mem.h $I/thread.h $I/sem.h
$Bthread-nt$O: $I/assert.h $I/except.h $I/mem.h $I/thread.h $I/sem.h
$Bxp$O: $I/assert.h $I/except.h $I/xp.h
eisl-5.55/cii/makefile.nt 0000664 0000000 0000000 00000017212 15066676224 0015311 0 ustar 00root root 0000000 0000000 # $Id$
BUILDDIR=^\lib^\cii^\1
A=.lib
O=.obj
E=.exe
I=include
CC=cl -nologo -DWIN32
B=$(BUILDDIR)^\
CFLAGS=-Zi -MTd -I$I
LD=cl -nologo
LDFLAGS=-Zi -MTd
THREADS=$Bthread-nt$O $Bchan$O
EXTRAS=
# $Id$
OBJS= $Bap$O \
$Barena$O \
$Barith$O \
$Barray$O \
$Bassert$O \
$Batom$O \
$Bbit$O \
$Bexcept$O \
$Bfmt$O \
$Blist$O \
$Bmem$O \
$Bmp$O \
$Bring$O \
$Bseq$O \
$Bset$O \
$Bstack$O \
$Bstr$O \
$Btable$O \
$Btext$O \
$Bxp$O \
$(THREADS)
EXAMPLES= $Bdouble$E \
$Bcalc$E \
$Bids$E \
$Bmpcalc$E \
$Bwf$E \
$Bxref$E \
$Bcref$E \
$Biref$E \
$Bkref$E \
$Bidents$E \
$Bwords$E \
$Bbasename$E \
$Bdirname$E \
$Bsort$E \
$Bspin$E \
$Bsieve$E
all:: $Blibcii$A $(EXAMPLES) $Bmemchk$O
$Blibcii$A:: $(OBJS) $(EXTRAS)
lib -nologo -out:$@ $(OBJS) $(EXTRAS)
$Bap$O: src/ap.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/ap.c
$Barena$O: src/arena.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/arena.c
$Barith$O: src/arith.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/arith.c
$Barray$O: src/array.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/array.c
$Bassert$O: src/assert.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/assert.c
$Batom$O: src/atom.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/atom.c
$Bbit$O: src/bit.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/bit.c
$Bchan$O: src/chan.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/chan.c
$Bexcept$O: src/except.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/except.c
$Bfmt$O: src/fmt.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/fmt.c
$Blist$O: src/list.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/list.c
$Bmem$O: src/mem.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/mem.c
$Bmemchk$O: src/memchk.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/memchk.c
$Bmp$O: src/mp.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/mp.c
$Bring$O: src/ring.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/ring.c
$Bseq$O: src/seq.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/seq.c
$Bset$O: src/set.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/set.c
$Bstack$O: src/stack.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/stack.c
$Bstr$O: src/str.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/str.c
$Btable$O: src/table.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/table.c
$Btext$O: src/text.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/text.c
$Bthread$O: src/thread.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/thread.c
$Bthread-nt$O: src/thread-nt.c;$(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/thread-nt.c
$Bxp$O: src/xp.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/xp.c
$Bswtch$O: src/swtch.s; as(,src/swtch.s,$@)
$Bmemcmp$O: src/memcmp.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/memcmp.c
$Bmemmove$O: src/memmove.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/memmove.c
$Bstrncmp$O: src/strncmp.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$Blibcii.pdb src/strncmp.c
$Bdouble$O: examples/double.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/double.c
$Bcalc$O: examples/calc.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/calc.c
$Bids$O: examples/ids.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/ids.c
$Bmpcalc$O: examples/mpcalc.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/mpcalc.c
$Biref$O: examples/iref.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/iref.c
$Bkref$O: examples/kref.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/kref.c
$Bidents$O: examples/idents.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/idents.c
$Bwords$O: examples/words.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/words.c
$Bbasename$O: examples/basename.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/basename.c
$Bwf$O: examples/wf.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/wf.c
$Bgetword$O: examples/getword.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/getword.c
$Bxref$O: examples/xref.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/xref.c
$Binteger$O: examples/integer.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/integer.c
$Bcref$O: examples/cref.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/cref.c
$Bsort$O: examples/sort.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/sort.c
$Bspin$O: examples/spin.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/spin.c
$Bsieve$O: examples/sieve.c; $(CC) $(CFLAGS) -c -Fo$@ -Fd$B examples/sieve.c
$Bwf$O $Bxref$O $Bgetword$O: examples/getword.h
$Bcref$O $Binteger$O: examples/integer.h
$Bdouble$E: $Bdouble$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bdouble$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bcalc$E: $Bcalc$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bcalc$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bids$E: $Bids$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bids$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bmpcalc$E: $Bmpcalc$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bmpcalc$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Biref$E: $Biref$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Biref$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bkref$E: $Bkref$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bkref$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bidents$E: $Bidents$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bidents$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bwords$E: $Bwords$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bwords$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bbasename$E: $Bbasename$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bbasename$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bdirname$E: $Bbasename$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bbasename$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bwf$E: $Bwf$O $Bgetword$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bwf$O $Bgetword$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bxref$E: $Bxref$O $Bgetword$O $Blibcii$A;$(LD) $(LDFLAGS) -Fe$@ $Bxref$O $Bgetword$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bcref$E: $Bcref$O $Binteger$O $Blibcii$A;$(LD) $(LDFLAGS) -Fe$@ $Bcref$O $Binteger$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bsort$E: $Bsort$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bsort$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bspin$E: $Bspin$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bspin$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
$Bsieve$E: $Bsieve$O $Blibcii$A; $(LD) $(LDFLAGS) -Fe$@ $Bsieve$O $Blibcii$A -link /NODEFAULTLIB:libc.lib
clean::
-del /q $B*$O
-del /q $(EXAMPLES)
clobber:: clean
-del /q $Blibcii$A
libcii.dll: $Blibcii.dll
$Blibcii.dll: $(OBJS) $(EXTRAS)
link -dll -out:$@ -def:src/libcii.def $(OBJS) $(EXTRAS)
clean::
-del /q $B*.ilk *.pdb
-move $Blibcii.pdb $Blibcii.bak
-del /q $B*.pdb
-move $Blibcii.bak $Blibcii.pdb
clobber::
-del /q $Blibcii.dll $Blibcii.exp
# DO NOT DELETE THIS LINE -- make depend depends on it.
$Bap$O: $I/assert.h $I/except.h $I/ap.h $I/fmt.h $I/xp.h $I/mem.h
$Barena$O: $I/assert.h $I/except.h $I/arena.h
$Barith$O: $I/arith.h
$Barray$O: $I/assert.h $I/except.h $I/array.h $I/arrayrep.h $I/mem.h
$Bassert$O: $I/assert.h $I/except.h
$Batom$O: $I/atom.h $I/assert.h $I/except.h $I/mem.h
$Bbit$O: $I/assert.h $I/except.h $I/bit.h $I/mem.h
$Bchan$O: $I/assert.h $I/except.h $I/mem.h $I/chan.h $I/sem.h
$Bexcept$O: $I/assert.h $I/except.h
$Bfmt$O: $I/assert.h $I/except.h $I/fmt.h $I/mem.h
$Blist$O: $I/assert.h $I/except.h $I/mem.h $I/list.h
$Bmem$O: $I/assert.h $I/except.h $I/mem.h
$Bmemchk$O: $I/assert.h $I/except.h $I/mem.h
$Bmp$O: $I/assert.h $I/except.h $I/fmt.h $I/mem.h $I/xp.h $I/mp.h
$Bring$O: $I/assert.h $I/except.h $I/ring.h $I/mem.h
$Bseq$O: $I/assert.h $I/except.h $I/seq.h $I/array.h $I/arrayrep.h $I/mem.h
$Bset$O: $I/mem.h $I/except.h $I/assert.h $I/arith.h $I/set.h
$Bstack$O: $I/assert.h $I/except.h $I/mem.h $I/stack.h
$Bstr$O: $I/assert.h $I/except.h $I/fmt.h $I/str.h $I/mem.h
$Btable$O: $I/mem.h $I/except.h $I/assert.h $I/table.h
$Btext$O: $I/assert.h $I/except.h $I/fmt.h $I/text.h $I/mem.h
$Bthread$O: $I/assert.h $I/except.h $I/mem.h $I/thread.h $I/sem.h
$Bthread-nt$O: $I/assert.h $I/except.h $I/mem.h $I/thread.h $I/sem.h
$Bxp$O: $I/assert.h $I/except.h $I/xp.h
eisl-5.55/cii/misc/ 0000775 0000000 0000000 00000000000 15066676224 0014121 5 ustar 00root root 0000000 0000000 eisl-5.55/cii/misc/maxalign.c 0000664 0000000 0000000 00000003653 15066676224 0016074 0 ustar 00root root 0000000 0000000 #include
#include
#include
#include
#include
/*
On most platforms, malloc returns pointers to blocks that are
aligned on addresses that are multiples of the size of the largest
basic data type. Some CII functions use a union to determine this
multiple (cf. union align on p. 80). Alignments are less restrictive
on some platforms and, for these, MAXALIGN must be defined as the
alignment required.
This program attempts to determine the correct value for MAXALIGN, if
one is necessary, and echo the appropriate -D option.
The method used relies on the C compiler using the same alignments as
malloc, which is not required. malloc is the final authority: If it
returns addresses that are multiples of sizeof (union align), then
MAXALIGN is unnecessary; otherwise, MAXALIGN must provide the
alignment. malloc(1) is called to determine if the address it returns
has an alignment less strict than that used by the C compiler.
Incorrect values of MAXALIGN can cause crashes and assertion failures.
*/
union align {
int i;
long l;
long *lp;
void *p;
void (*fp)(void);
float f;
double d;
long double ld;
};
typedef void (*functp);
#define yy \
xx(int,i);\
xx(long,l);\
xx(long *,lp);\
xx(void *,p);\
xx(functp,fp);\
xx(float,f);\
xx(double,d);\
xx(long double,ld);
int main(int argc, char *argv[]) {
#define xx(t,v) struct { char pad; t v; } v
yy
#undef xx
unsigned max = 0;
int verbose = 0;
#define xx(t,v) if ((char *)&v.v - &v.pad > max) max = (char *)&v.v - &v.pad
yy
#undef xx
if (argc > 1 && strcmp(argv[1], "-v") == 0)
verbose = 1;
if (verbose)
fprintf(stderr, "sizeof (union align) = %u\n", sizeof (union align));
assert(max);
char *ptr = malloc(1);
if (verbose)
fprintf(stderr, "malloc(1) = %p\n", ptr);
while (max > 0 && ((unsigned)ptr)%max != 0)
max /= 2;
assert(max);
if (max != sizeof (union align))
printf("-DMAXALIGN=%u\n", max);
return EXIT_SUCCESS;
}
eisl-5.55/cii/patched 0000664 0000000 0000000 00000000000 15066676224 0014507 0 ustar 00root root 0000000 0000000 eisl-5.55/cii/src/ 0000775 0000000 0000000 00000000000 15066676224 0013755 5 ustar 00root root 0000000 0000000 eisl-5.55/cii/src/ap.c 0000664 0000000 0000000 00000021106 15066676224 0014521 0 ustar 00root root 0000000 0000000 static const char *rcsid = "$Id$";
#include
#include
#include
#include
#include "assert.h"
#include "ap.h"
#include "fmt.h"
#include "xp.h"
#include "mem.h"
#define T AP_T
struct T {
int sign;
int ndigits;
int size;
XP_T digits;
};
#define iszero(x) ((x)->ndigits==1 && (x)->digits[0]==0)
#define maxdigits(x,y) ((x)->ndigits > (y)->ndigits ? \
(x)->ndigits : (y)->ndigits)
#define isone(x) ((x)->ndigits==1 && (x)->digits[0]==1)
static T normalize(T z, int n);
static int cmp(T x, T y);
static T mk(int size) {
T z = CALLOC(1, sizeof (*z) + size);
assert(size > 0);
z->sign = 1;
z->size = size;
z->ndigits = 1;
z->digits = (XP_T)(z + 1);
return z;
}
static T set(T z, long int n) {
if (n == LONG_MIN)
XP_fromint(z->size, z->digits, LONG_MAX + 1UL);
else if (n < 0)
XP_fromint(z->size, z->digits, -n);
else
XP_fromint(z->size, z->digits, n);
z->sign = n < 0 ? -1 : 1;
return normalize(z, z->size);
}
static T normalize(T z, int n) {
z->ndigits = XP_length(n, z->digits);
return z;
}
static T add(T z, T x, T y) {
int n = y->ndigits;
if (x->ndigits < n)
return add(z, y, x);
else if (x->ndigits > n) {
int carry = XP_add(n, z->digits, x->digits,
y->digits, 0);
z->digits[z->size-1] = XP_sum(x->ndigits - n,
&z->digits[n], &x->digits[n], carry);
} else
z->digits[n] = XP_add(n, z->digits, x->digits,
y->digits, 0);
return normalize(z, z->size);
}
static T sub(T z, T x, T y) {
int borrow, n = y->ndigits;
borrow = XP_sub(n, z->digits, x->digits,
y->digits, 0);
if (x->ndigits > n)
borrow = XP_diff(x->ndigits - n, &z->digits[n],
&x->digits[n], borrow);
assert(borrow == 0);
return normalize(z, z->size);
}
static T mulmod(T x, T y, T p) {
T z, xy = AP_mul(x, y);
z = AP_mod(xy, p);
AP_free(&xy);
return z;
}
static int cmp(T x, T y) {
if (x->ndigits != y->ndigits)
return x->ndigits - y->ndigits;
else
return XP_cmp(x->ndigits, x->digits, y->digits);
}
T AP_new(long int n) {
return set(mk(sizeof (long int)), n);
}
void AP_free(T *z) {
assert(z && *z);
FREE(*z);
}
T AP_neg(T x) {
T z;
assert(x);
z = mk(x->ndigits);
memcpy(z->digits, x->digits, x->ndigits);
z->ndigits = x->ndigits;
z->sign = iszero(z) ? 1 : -x->sign;
return z;
}
T AP_mul(T x, T y) {
T z;
assert(x);
assert(y);
z = mk(x->ndigits + y->ndigits);
XP_mul(z->digits, x->ndigits, x->digits, y->ndigits,
y->digits);
normalize(z, z->size);
z->sign = iszero(z)
|| ((x->sign^y->sign) == 0) ? 1 : -1;
return z;
}
T AP_add(T x, T y) {
T z;
assert(x);
assert(y);
if (((x->sign^y->sign) == 0)) {
z = add(mk(maxdigits(x,y) + 1), x, y);
z->sign = iszero(z) ? 1 : x->sign;
} else
if (cmp(x, y) > 0) {
z = sub(mk(x->ndigits), x, y);
z->sign = iszero(z) ? 1 : x->sign;
}
else {
z = sub(mk(y->ndigits), y, x);
z->sign = iszero(z) ? 1 : -x->sign;
}
return z;
}
T AP_sub(T x, T y) {
T z;
assert(x);
assert(y);
if (!((x->sign^y->sign) == 0)) {
z = add(mk(maxdigits(x,y) + 1), x, y);
z->sign = iszero(z) ? 1 : x->sign;
} else
if (cmp(x, y) > 0) {
z = sub(mk(x->ndigits), x, y);
z->sign = iszero(z) ? 1 : x->sign;
} else {
z = sub(mk(y->ndigits), y, x);
z->sign = iszero(z) ? 1 : -x->sign;
}
return z;
}
T AP_div(T x, T y) {
T q, r;
assert(x);
assert(y);
assert(!iszero(y));
q = mk(x->ndigits);
r = mk(y->ndigits);
{
XP_T tmp = ALLOC(x->ndigits + y->ndigits + 2);
XP_div(x->ndigits, q->digits, x->digits,
y->ndigits, y->digits, r->digits, tmp);
FREE(tmp);
}
normalize(q, q->size);
normalize(r, r->size);
q->sign = iszero(q)
|| ((x->sign^y->sign) == 0) ? 1 : -1;
if (!((x->sign^y->sign) == 0) && !iszero(r)) {
int carry = XP_sum(q->size, q->digits,
q->digits, 1);
assert(carry == 0);
normalize(q, q->size);
}
AP_free(&r);
return q;
}
T AP_mod(T x, T y) {
T q, r;
assert(x);
assert(y);
assert(!iszero(y));
q = mk(x->ndigits);
r = mk(y->ndigits);
{
XP_T tmp = ALLOC(x->ndigits + y->ndigits + 2);
XP_div(x->ndigits, q->digits, x->digits,
y->ndigits, y->digits, r->digits, tmp);
FREE(tmp);
}
normalize(q, q->size);
normalize(r, r->size);
q->sign = iszero(q)
|| ((x->sign^y->sign) == 0) ? 1 : -1;
if (!((x->sign^y->sign) == 0) && !iszero(r)) {
int borrow = XP_sub(r->size, r->digits,
y->digits, r->digits, 0);
assert(borrow == 0);
normalize(r, r->size);
}
AP_free(&q);
return r;
}
T AP_pow(T x, T y, T p) {
T z;
assert(x);
assert(y);
assert(y->sign == 1);
assert(!p || p->sign==1 && !iszero(p) && !isone(p));
if (iszero(x))
return AP_new(0);
if (iszero(y))
return AP_new(1);
if (isone(x))
return AP_new((((y)->digits[0]&1) == 0) ? 1 : x->sign);
if (p)
if (isone(y))
z = AP_mod(x, p);
else {
T y2 = AP_rshift(y, 1), t = AP_pow(x, y2, p);
z = mulmod(t, t, p);
AP_free(&y2);
AP_free(&t);
if (!(((y)->digits[0]&1) == 0)) {
z = mulmod(y2 = AP_mod(x, p), t = z, p);
AP_free(&y2);
AP_free(&t);
}
}
else
if (isone(y))
z = AP_addi(x, 0);
else {
T y2 = AP_rshift(y, 1), t = AP_pow(x, y2, NULL);
z = AP_mul(t, t);
AP_free(&y2);
AP_free(&t);
if (!(((y)->digits[0]&1) == 0)) {
z = AP_mul(x, t = z);
AP_free(&t);
}
}
return z;
}
int AP_cmp(T x, T y) {
assert(x);
assert(y);
if (!((x->sign^y->sign) == 0))
return x->sign;
else if (x->sign == 1)
return cmp(x, y);
else
return cmp(y, x);
}
T AP_addi(T x, long int y) {
unsigned char d[sizeof (unsigned long)];
struct T t;
t.size = sizeof d;
t.digits = d;
return AP_add(x, set(&t, y));
}
T AP_subi(T x, long int y) {
unsigned char d[sizeof (unsigned long)];
struct T t;
t.size = sizeof d;
t.digits = d;
return AP_sub(x, set(&t, y));
}
T AP_muli(T x, long int y) {
unsigned char d[sizeof (unsigned long)];
struct T t;
t.size = sizeof d;
t.digits = d;
return AP_mul(x, set(&t, y));
}
T AP_divi(T x, long int y) {
unsigned char d[sizeof (unsigned long)];
struct T t;
t.size = sizeof d;
t.digits = d;
return AP_div(x, set(&t, y));
}
int AP_cmpi(T x, long int y) {
unsigned char d[sizeof (unsigned long)];
struct T t;
t.size = sizeof d;
t.digits = d;
return AP_cmp(x, set(&t, y));
}
long int AP_modi(T x, long int y) {
long int rem;
T r;
unsigned char d[sizeof (unsigned long)];
struct T t;
t.size = sizeof d;
t.digits = d;
r = AP_mod(x, set(&t, y));
rem = XP_toint(r->ndigits, r->digits);
AP_free(&r);
return rem;
}
T AP_lshift(T x, int s) {
T z;
assert(x);
assert(s >= 0);
z = mk(x->ndigits + ((s+7)&~7)/8);
XP_lshift(z->size, z->digits, x->ndigits,
x->digits, s, 0);
z->sign = x->sign;
return normalize(z, z->size);
}
T AP_rshift(T x, int s) {
assert(x);
assert(s >= 0);
if (s >= 8*x->ndigits)
return AP_new(0);
else {
T z = mk(x->ndigits - s/8);
XP_rshift(z->size, z->digits, x->ndigits,
x->digits, s, 0);
normalize(z, z->size);
z->sign = iszero(z) ? 1 : x->sign;
return z;
}
}
long int AP_toint(T x) {
unsigned long u;
assert(x);
u = XP_toint(x->ndigits, x->digits)%(LONG_MAX + 1UL);
if (x->sign == -1)
return -(long)u;
else
return (long)u;
}
T AP_fromstr(const char *str, int base, char **end) {
T z;
const char *p = str;
char *endp, sign = '\0';
int carry;
assert(p);
assert(base >= 2 && base <= 36);
while (*p && isspace(*p))
p++;
if (*p == '-' || *p == '+')
sign = *p++;
{
const char *start;
int k, n = 0;
for ( ; *p == '0' && p[1] == '0'; p++)
;
start = p;
for ( ; ( '0' <= *p && *p <= '9' && *p < '0' + base
|| 'a' <= *p && *p <= 'z' && *p < 'a' + base - 10
|| 'A' <= *p && *p <= 'Z' && *p < 'A' + base - 10); p++)
n++;
for (k = 1; (1<size, z->digits, p,
base, &endp);
assert(carry == 0);
normalize(z, z->size);
if (endp == p) {
endp = (char *)str;
z = AP_new(0);
} else
z->sign = iszero(z) || sign != '-' ? 1 : -1;
if (end)
*end = (char *)endp;
return z;
}
char *AP_tostr(char *str, int size, int base, T x) {
XP_T q;
assert(x);
assert(base >= 2 && base <= 36);
assert(str == NULL || size > 1);
if (str == NULL) {
{
int k;
for (k = 5; (1< base; k--)
;
size = (8*x->ndigits)/k + 1 + 1;
if (x->sign == -1)
size++;
}
str = ALLOC(size);
}
q = ALLOC(x->ndigits);
memcpy(q, x->digits, x->ndigits);
if (x->sign == -1) {
str[0] = '-';
XP_tostr(str + 1, size - 1, base, x->ndigits, q);
} else
XP_tostr(str, size, base, x->ndigits, q);
FREE(q);
return str;
}
void AP_fmt(int code, va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
T x;
char *buf;
assert(box && flags);
x = va_arg(box->ap, T);
assert(x);
buf = AP_tostr(NULL, 0, 10, x);
Fmt_putd(buf, strlen(buf), put, cl, flags,
width, precision);
FREE(buf);
}
eisl-5.55/cii/src/arena.c 0000664 0000000 0000000 00000004311 15066676224 0015206 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include
#include "assert.h"
#include "except.h"
#include "arena.h"
#define T Arena_T
const Except_T Arena_NewFailed =
{ "Arena creation failed" };
const Except_T Arena_Failed =
{ "Arena allocation failed" };
#define THRESHOLD 10
struct T {
T prev;
char *avail;
char *limit;
};
union align {
#ifdef MAXALIGN
char pad[MAXALIGN];
#else
int i;
long l;
long *lp;
void *p;
void (*fp)(void);
float f;
double d;
long double ld;
#endif
};
union header {
struct T b;
union align a;
};
static T freechunks;
static int nfree;
T Arena_new(void) {
T arena = malloc(sizeof (*arena));
if (arena == NULL)
RAISE(Arena_NewFailed);
arena->prev = NULL;
arena->limit = arena->avail = NULL;
return arena;
}
void Arena_dispose(T *ap) {
assert(ap && *ap);
Arena_free(*ap);
free(*ap);
*ap = NULL;
}
void *Arena_alloc(T arena, long nbytes,
const char *file, int line) {
assert(arena);
assert(nbytes > 0);
nbytes = ((nbytes + sizeof (union align) - 1)/
(sizeof (union align)))*(sizeof (union align));
while (nbytes > arena->limit - arena->avail) {
T ptr;
char *limit;
if ((ptr = freechunks) != NULL) {
freechunks = freechunks->prev;
nfree--;
limit = ptr->limit;
} else {
long m = sizeof (union header) + nbytes + 10*1024;
ptr = malloc(m);
if (ptr == NULL)
{
if (file == NULL)
RAISE(Arena_Failed);
else
Except_raise(&Arena_Failed, file, line);
}
limit = (char *)ptr + m;
}
*ptr = *arena;
arena->avail = (char *)((union header *)ptr + 1);
arena->limit = limit;
arena->prev = ptr;
}
arena->avail += nbytes;
return arena->avail - nbytes;
}
void *Arena_calloc(T arena, long count, long nbytes,
const char *file, int line) {
void *ptr;
assert(count > 0);
ptr = Arena_alloc(arena, count*nbytes, file, line);
memset(ptr, '\0', count*nbytes);
return ptr;
}
void Arena_free(T arena) {
assert(arena);
while (arena->prev) {
struct T tmp = *arena->prev;
if (nfree < THRESHOLD) {
arena->prev->prev = freechunks;
freechunks = arena->prev;
nfree++;
freechunks->limit = arena->limit;
} else
free(arena->prev);
*arena = tmp;
}
assert(arena->limit == NULL);
assert(arena->avail == NULL);
}
eisl-5.55/cii/src/arith.c 0000664 0000000 0000000 00000001032 15066676224 0015224 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include "arith.h"
int Arith_max(int x, int y) {
return x > y ? x : y;
}
int Arith_min(int x, int y) {
return x > y ? y : x;
}
int Arith_div(int x, int y) {
if (-13/5 == -2
&& (x < 0) != (y < 0) && x%y != 0)
return x/y - 1;
else
return x/y;
}
int Arith_mod(int x, int y) {
if (-13/5 == -2
&& (x < 0) != (y < 0) && x%y != 0)
return x%y + y;
else
return x%y;
}
int Arith_floor(int x, int y) {
return Arith_div(x, y);
}
int Arith_ceiling(int x, int y) {
return Arith_div(x, y) + (x%y != 0);
}
eisl-5.55/cii/src/array.c 0000664 0000000 0000000 00000003477 15066676224 0015252 0 ustar 00root root 0000000 0000000 static const char *rcsid = "$Id$";
#include
#include
#include "assert.h"
#include "array.h"
#include "arrayrep.h"
#include "mem.h"
#define T Array_T
T Array_new(int length, int size) {
T array;
NEW(array);
if (length > 0)
ArrayRep_init(array, length, size,
CALLOC(length, size));
else
ArrayRep_init(array, length, size, NULL);
return array;
}
void ArrayRep_init(T array, int length, int size,
void *ary) {
assert(array);
assert(ary && length>0 || length==0 && ary==NULL);
assert(size > 0);
array->length = length;
array->size = size;
if (length > 0)
array->array = ary;
else
array->array = NULL;
}
void Array_free(T *array) {
assert(array && *array);
FREE((*array)->array);
FREE(*array);
}
void *Array_get(T array, int i) {
assert(array);
assert(i >= 0 && i < array->length);
return array->array + i*array->size;
}
void *Array_put(T array, int i, void *elem) {
assert(array);
assert(i >= 0 && i < array->length);
assert(elem);
memcpy(array->array + i*array->size, elem,
array->size);
return elem;
}
int Array_length(T array) {
assert(array);
return array->length;
}
int Array_size(T array) {
assert(array);
return array->size;
}
void Array_resize(T array, int length) {
assert(array);
assert(length >= 0);
if (length == 0)
FREE(array->array);
else if (array->length == 0)
array->array = ALLOC(length*array->size);
else
RESIZE(array->array, length*array->size);
array->length = length;
}
T Array_copy(T array, int length) {
T copy;
assert(array);
assert(length >= 0);
copy = Array_new(length, array->size);
if (copy->length >= array->length
&& array->length > 0)
memcpy(copy->array, array->array,
array->length*array->size);
else if (array->length > copy->length
&& copy->length > 0)
memcpy(copy->array, array->array,
copy->length*array->size);
return copy;
}
eisl-5.55/cii/src/assert.c 0000664 0000000 0000000 00000000216 15066676224 0015421 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include "assert.h"
const Except_T Assert_Failed = { "Assertion failed" };
void (assert)(int e) {
assert(e);
}
eisl-5.55/cii/src/atom.c 0000664 0000000 0000000 00000010522 15066676224 0015061 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include "atom.h"
#include
#include "assert.h"
#include
#include "mem.h"
#define NELEMS(x) ((sizeof (x))/(sizeof ((x)[0])))
static struct atom {
struct atom *link;
int len;
char *str;
} *buckets[2048];
static unsigned long scatter[] = {
2078917053, 143302914, 1027100827, 1953210302, 755253631, 2002600785,
1405390230, 45248011, 1099951567, 433832350, 2018585307, 438263339,
813528929, 1703199216, 618906479, 573714703, 766270699, 275680090,
1510320440, 1583583926, 1723401032, 1965443329, 1098183682, 1636505764,
980071615, 1011597961, 643279273, 1315461275, 157584038, 1069844923,
471560540, 89017443, 1213147837, 1498661368, 2042227746, 1968401469,
1353778505, 1300134328, 2013649480, 306246424, 1733966678, 1884751139,
744509763, 400011959, 1440466707, 1363416242, 973726663, 59253759,
1639096332, 336563455, 1642837685, 1215013716, 154523136, 593537720,
704035832, 1134594751, 1605135681, 1347315106, 302572379, 1762719719,
269676381, 774132919, 1851737163, 1482824219, 125310639, 1746481261,
1303742040, 1479089144, 899131941, 1169907872, 1785335569, 485614972,
907175364, 382361684, 885626931, 200158423, 1745777927, 1859353594,
259412182, 1237390611, 48433401, 1902249868, 304920680, 202956538,
348303940, 1008956512, 1337551289, 1953439621, 208787970, 1640123668,
1568675693, 478464352, 266772940, 1272929208, 1961288571, 392083579,
871926821, 1117546963, 1871172724, 1771058762, 139971187, 1509024645,
109190086, 1047146551, 1891386329, 994817018, 1247304975, 1489680608,
706686964, 1506717157, 579587572, 755120366, 1261483377, 884508252,
958076904, 1609787317, 1893464764, 148144545, 1415743291, 2102252735,
1788268214, 836935336, 433233439, 2055041154, 2109864544, 247038362,
299641085, 834307717, 1364585325, 23330161, 457882831, 1504556512,
1532354806, 567072918, 404219416, 1276257488, 1561889936, 1651524391,
618454448, 121093252, 1010757900, 1198042020, 876213618, 124757630,
2082550272, 1834290522, 1734544947, 1828531389, 1982435068, 1002804590,
1783300476, 1623219634, 1839739926, 69050267, 1530777140, 1802120822,
316088629, 1830418225, 488944891, 1680673954, 1853748387, 946827723,
1037746818, 1238619545, 1513900641, 1441966234, 367393385, 928306929,
946006977, 985847834, 1049400181, 1956764878, 36406206, 1925613800,
2081522508, 2118956479, 1612420674, 1668583807, 1800004220, 1447372094,
523904750, 1435821048, 923108080, 216161028, 1504871315, 306401572,
2018281851, 1820959944, 2136819798, 359743094, 1354150250, 1843084537,
1306570817, 244413420, 934220434, 672987810, 1686379655, 1301613820,
1601294739, 484902984, 139978006, 503211273, 294184214, 176384212,
281341425, 228223074, 147857043, 1893762099, 1896806882, 1947861263,
1193650546, 273227984, 1236198663, 2116758626, 489389012, 593586330,
275676551, 360187215, 267062626, 265012701, 719930310, 1621212876,
2108097238, 2026501127, 1865626297, 894834024, 552005290, 1404522304,
48964196, 5816381, 1889425288, 188942202, 509027654, 36125855,
365326415, 790369079, 264348929, 513183458, 536647531, 13672163,
313561074, 1730298077, 286900147, 1549759737, 1699573055, 776289160,
2143346068, 1975249606, 1136476375, 262925046, 92778659, 1856406685,
1884137923, 53392249, 1735424165, 1602280572
};
const char *Atom_string(const char *str) {
assert(str);
return Atom_new(str, strlen(str));
}
const char *Atom_int(long n) {
char str[43];
char *s = str + sizeof str;
unsigned long m;
if (n == LONG_MIN)
m = LONG_MAX + 1UL;
else if (n < 0)
m = -n;
else
m = n;
do
*--s = m%10 + '0';
while ((m /= 10) > 0);
if (n < 0)
*--s = '-';
return Atom_new(s, (str + sizeof str) - s);
}
const char *Atom_new(const char *str, int len) {
unsigned long h;
int i;
struct atom *p;
assert(str);
assert(len >= 0);
for (h = 0, i = 0; i < len; i++)
h = (h<<1) + scatter[(unsigned char)str[i]];
h &= NELEMS(buckets)-1;
for (p = buckets[h]; p; p = p->link)
if (len == p->len) {
for (i = 0; i < len && p->str[i] == str[i]; )
i++;
if (i == len)
return p->str;
}
p = ALLOC(sizeof (*p) + len + 1);
p->len = len;
p->str = (char *)(p + 1);
if (len > 0)
memcpy(p->str, str, len);
p->str[len] = '\0';
p->link = buckets[h];
buckets[h] = p;
return p->str;
}
int Atom_length(const char *str) {
struct atom *p;
int i;
assert(str);
for (i = 0; i < NELEMS(buckets); i++)
for (p = buckets[i]; p; p = p->link)
if (p->str == str)
return p->len;
assert(0);
return 0;
}
eisl-5.55/cii/src/bit.c 0000664 0000000 0000000 00000010210 15066676224 0014671 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include
#include "assert.h"
#include "bit.h"
#include "mem.h"
#define T Bit_T
struct T {
int length;
unsigned char *bytes;
unsigned long *words;
};
#define BPW (8*sizeof (unsigned long))
#define nwords(len) ((((len) + BPW - 1)&(~(BPW-1)))/BPW)
#define nbytes(len) ((((len) + 8 - 1)&(~(8-1)))/8)
#define setop(sequal, snull, tnull, op) \
if (s == t) { assert(s); return sequal; } \
else if (s == NULL) { assert(t); return snull; } \
else if (t == NULL) return tnull; \
else { \
int i; T set; \
assert(s->length == t->length); \
set = Bit_new(s->length); \
for (i = nwords(s->length); --i >= 0; ) \
set->words[i] = s->words[i] op t->words[i]; \
return set; }
unsigned char msbmask[] = {
0xFF, 0xFE, 0xFC, 0xF8,
0xF0, 0xE0, 0xC0, 0x80
};
unsigned char lsbmask[] = {
0x01, 0x03, 0x07, 0x0F,
0x1F, 0x3F, 0x7F, 0xFF
};
static T copy(T t) {
T set;
assert(t);
set = Bit_new(t->length);
if (t->length > 0)
memcpy(set->bytes, t->bytes, nbytes(t->length));
return set;
}
T Bit_new(int length) {
T set;
assert(length >= 0);
NEW(set);
if (length > 0)
set->words = CALLOC(nwords(length),
sizeof (unsigned long));
else
set->words = NULL;
set->bytes = (unsigned char *)set->words;
set->length = length;
return set;
}
void Bit_free(T *set) {
assert(set && *set);
FREE((*set)->words);
FREE(*set);
}
int Bit_length(T set) {
assert(set);
return set->length;
}
int Bit_count(T set) {
int length = 0, n;
static char count[] = {
0,1,1,2,1,2,2,3,1,2,2,3,2,3,3,4 };
assert(set);
for (n = nbytes(set->length); --n >= 0; ) {
unsigned char c = set->bytes[n];
length += count[c&0xF] + count[c>>4];
}
return length;
}
int Bit_get(T set, int n) {
assert(set);
assert(0 <= n && n < set->length);
return ((set->bytes[n/8]>>(n%8))&1);
}
int Bit_put(T set, int n, int bit) {
int prev;
assert(set);
assert(bit == 0 || bit == 1);
assert(0 <= n && n < set->length);
prev = ((set->bytes[n/8]>>(n%8))&1);
if (bit == 1)
set->bytes[n/8] |= 1<<(n%8);
else
set->bytes[n/8] &= ~(1<<(n%8));
return prev;
}
void Bit_set(T set, int lo, int hi) {
assert(set);
assert(0 <= lo && hi < set->length);
assert(lo <= hi);
if (lo/8 < hi/8) {
set->bytes[lo/8] |= msbmask[lo%8];
{
int i;
for (i = lo/8+1; i < hi/8; i++)
set->bytes[i] = 0xFF;
}
set->bytes[hi/8] |= lsbmask[hi%8];
} else
set->bytes[lo/8] |= (msbmask[lo%8]&lsbmask[hi%8]);
}
void Bit_clear(T set, int lo, int hi) {
assert(set);
assert(0 <= lo && hi < set->length);
assert(lo <= hi);
if (lo/8 < hi/8) {
int i;
set->bytes[lo/8] &= ~msbmask[lo%8];
for (i = lo/8+1; i < hi/8; i++)
set->bytes[i] = 0;
set->bytes[hi/8] &= ~lsbmask[hi%8];
} else
set->bytes[lo/8] &= ~(msbmask[lo%8]&lsbmask[hi%8]);
}
void Bit_not(T set, int lo, int hi) {
assert(set);
assert(0 <= lo && hi < set->length);
assert(lo <= hi);
if (lo/8 < hi/8) {
int i;
set->bytes[lo/8] ^= msbmask[lo%8];
for (i = lo/8+1; i < hi/8; i++)
set->bytes[i] ^= 0xFF;
set->bytes[hi/8] ^= lsbmask[hi%8];
} else
set->bytes[lo/8] ^= (msbmask[lo%8]&lsbmask[hi%8]);
}
void Bit_map(T set,
void apply(int n, int bit, void *cl), void *cl) {
int n;
assert(set);
for (n = 0; n < set->length; n++)
apply(n, ((set->bytes[n/8]>>(n%8))&1), cl);
}
int Bit_eq(T s, T t) {
int i;
assert(s && t);
assert(s->length == t->length);
for (i = nwords(s->length); --i >= 0; )
if (s->words[i] != t->words[i])
return 0;
return 1;
}
int Bit_leq(T s, T t) {
int i;
assert(s && t);
assert(s->length == t->length);
for (i = nwords(s->length); --i >= 0; )
if ((s->words[i]&~t->words[i]) != 0)
return 0;
return 1;
}
int Bit_lt(T s, T t) {
int i, lt = 0;
assert(s && t);
assert(s->length == t->length);
for (i = nwords(s->length); --i >= 0; )
if ((s->words[i]&~t->words[i]) != 0)
return 0;
else if (s->words[i] != t->words[i])
lt |= 1;
return lt;
}
T Bit_union(T s, T t) {
setop(copy(t), copy(t), copy(s), |)
}
T Bit_inter(T s, T t) {
setop(copy(t),
Bit_new(t->length), Bit_new(s->length), &)
}
T Bit_minus(T s, T t) {
setop(Bit_new(s->length),
Bit_new(t->length), copy(s), & ~)
}
T Bit_diff(T s, T t) {
setop(Bit_new(s->length), copy(t), copy(s), ^)
}
eisl-5.55/cii/src/chan.c 0000664 0000000 0000000 00000001463 15066676224 0015036 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include "assert.h"
#include "mem.h"
#include "chan.h"
#include "sem.h"
#define T Chan_T
struct T {
const void *ptr;
int *size;
Sem_T send, recv, sync;
};
T Chan_new(void) {
T c;
NEW(c);
Sem_init(&c->send, 1);
Sem_init(&c->recv, 0);
Sem_init(&c->sync, 0);
return c;
}
int Chan_send(Chan_T c, const void *ptr, int size) {
assert(c);
assert(ptr);
assert(size >= 0);
Sem_wait(&c->send);
c->ptr = ptr;
c->size = &size;
Sem_signal(&c->recv);
Sem_wait(&c->sync);
return size;
}
int Chan_receive(Chan_T c, void *ptr, int size) {
int n;
assert(c);
assert(ptr);
assert(size >= 0);
Sem_wait(&c->recv);
n = *c->size;
if (size < n)
n = size;
*c->size = n;
if (n > 0)
memcpy(ptr, c->ptr, n);
Sem_signal(&c->sync);
Sem_signal(&c->send);
return n;
}
eisl-5.55/cii/src/except.c 0000664 0000000 0000000 00000003020 15066676224 0015404 0 ustar 00root root 0000000 0000000 //static char rcsid[] = "$Id$" "\n$Id$";
#include
#include
#include
#include "assert.h"
#include "except.h"
#define T Except_T
Except_Frame *Except_stack = NULL;
void Except_raise(const T *e, const char *file,
int line) {
#ifdef WIN32
Except_Frame *p;
if (Except_index == -1)
Except_init();
p = TlsGetValue(Except_index);
#else
Except_Frame *p = Except_stack;
#endif
assert(e);
if (p == NULL) {
fprintf(stderr, "Uncaught exception");
if (e->reason)
fprintf(stderr, " %s", e->reason);
else
fprintf(stderr, " at 0x%p", e);
if (file && line > 0)
fprintf(stderr, " raised at %s:%d\n", file, line);
fprintf(stderr, "aborting...\n");
fflush(stderr);
abort();
}
p->exception = e;
p->file = file;
p->line = line;
#ifdef WIN32
Except_pop();
#else
Except_stack = Except_stack->prev;
#endif
longjmp(p->env, Except_raised);
}
#ifdef WIN32
_CRTIMP void __cdecl _assert(void *, void *, unsigned);
#undef assert
#define assert(e) ((e) || (_assert(#e, __FILE__, __LINE__), 0))
int Except_index = -1;
void Except_init(void) {
BOOL cond;
Except_index = TlsAlloc();
assert(Except_index != TLS_OUT_OF_INDEXES);
cond = TlsSetValue(Except_index, NULL);
assert(cond == TRUE);
}
void Except_push(Except_Frame *fp) {
BOOL cond;
fp->prev = TlsGetValue(Except_index);
cond = TlsSetValue(Except_index, fp);
assert(cond == TRUE);
}
void Except_pop(void) {
BOOL cond;
Except_Frame *tos = TlsGetValue(Except_index);
cond = TlsSetValue(Except_index, tos->prev);
assert(cond == TRUE);
}
#endif
eisl-5.55/cii/src/fmt.c 0000664 0000000 0000000 00000022153 15066676224 0014712 0 ustar 00root root 0000000 0000000 //static char rcsid[] = "$Id$";
#include
#include
#include
#include
#include
#include
#include
#include
#include "assert.h"
#include "except.h"
#include "fmt.h"
#include "mem.h"
#define T Fmt_T
struct buf {
char *buf;
char *bp;
int size;
};
#define pad(n,c) do { int nn = (n); \
while (nn-- > 0) \
put((c), cl); } while (0)
static void cvt_s(int code , va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
char *str = va_arg(box->ap, char *);
assert(str);
Fmt_puts(str, strlen(str), put, cl, flags,
width, precision);
}
static void cvt_d(int code , va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
int val = va_arg(box->ap, int);
unsigned m;
char buf[43];
char *p = buf + sizeof buf;
if (val == INT_MIN)
m = INT_MAX + 1U;
else if (val < 0)
m = -val;
else
m = val;
do
*--p = m%10 + '0';
while ((m /= 10) > 0);
if (val < 0)
*--p = '-';
Fmt_putd(p, (buf + sizeof buf) - p, put, cl, flags,
width, precision);
}
static void cvt_u(int code , va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
unsigned m = va_arg(box->ap, unsigned);
char buf[43];
char *p = buf + sizeof buf;
do
*--p = m%10 + '0';
while ((m /= 10) > 0);
Fmt_putd(p, (buf + sizeof buf) - p, put, cl, flags,
width, precision);
}
static void cvt_o(int code , va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
unsigned m = va_arg(box->ap, unsigned);
char buf[43];
char *p = buf + sizeof buf;
do
*--p = (m&0x7) + '0';
while ((m>>= 3) != 0);
Fmt_putd(p, (buf + sizeof buf) - p, put, cl, flags,
width, precision);
}
static void cvt_x(int code , va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
unsigned m = va_arg(box->ap, unsigned);
char buf[43];
char *p = buf + sizeof buf;
do
*--p = "0123456789abcdef"[m&0xf];
while ((m>>= 4) != 0);
Fmt_putd(p, (buf + sizeof buf) - p, put, cl, flags,
width, precision);
}
static void cvt_p(int code , va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
unsigned long m = (unsigned long)va_arg(box->ap, void*);
char buf[43];
char *p = buf + sizeof buf;
precision = INT_MIN;
do
*--p = "0123456789abcdef"[m&0xf];
while ((m>>= 4) != 0);
Fmt_putd(p, (buf + sizeof buf) - p, put, cl, flags,
width, precision);
}
static void cvt_c(int code , va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision ) {
if (width == INT_MIN)
width = 0;
if (width < 0) {
flags['-'] = 1;
width = -width;
}
if (!flags['-'])
pad(width - 1, ' ');
put((unsigned char)va_arg(box->ap, int), cl);
if ( flags['-'])
pad(width - 1, ' ');
}
static void cvt_f(int code, va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
char buf[DBL_MAX_10_EXP+1+1+99+1];
if (precision < 0)
precision = 6;
if (code == 'g' && precision == 0)
precision = 1;
{
static char fmt[] = "%.dd?";
assert(precision <= 99);
fmt[4] = code;
fmt[3] = precision%10 + '0';
fmt[2] = (precision/10)%10 + '0';
sprintf(buf, fmt, va_arg(box->ap, double));
}
Fmt_putd(buf, strlen(buf), put, cl, flags,
width, precision);
}
const Except_T Fmt_Overflow = { "Formatting Overflow" };
static T cvt[256] = {
/* 0- 7 */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 8- 15 */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 16- 23 */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 24- 31 */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 32- 39 */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 40- 47 */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 48- 55 */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 56- 63 */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 64- 71 */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 72- 79 */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 80- 87 */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 88- 95 */ 0, 0, 0, 0, 0, 0, 0, 0,
/* 96-103 */ 0, 0, 0, cvt_c, cvt_d, cvt_f, cvt_f, cvt_f,
/* 104-111 */ 0, 0, 0, 0, 0, 0, 0, cvt_o,
/* 112-119 */ cvt_p, 0, 0, cvt_s, 0, cvt_u, 0, 0,
/* 120-127 */ cvt_x, 0, 0, 0, 0, 0, 0, 0
};
char *Fmt_flags = "-+ 0";
static int outc(int c, void *cl) {
FILE *f = cl;
return putc(c, f);
}
static int insert(int c, void *cl) {
struct buf *p = cl;
if (p->bp >= p->buf + p->size)
RAISE(Fmt_Overflow);
*p->bp++ = c;
return c;
}
static int append(int c, void *cl) {
struct buf *p = cl;
if (p->bp >= p->buf + p->size) {
RESIZE(p->buf, 2*p->size);
p->bp = p->buf + p->size;
p->size *= 2;
}
*p->bp++ = c;
return c;
}
void Fmt_puts(const char *str, int len,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
assert(str);
assert(len >= 0);
assert(flags);
if (width == INT_MIN)
width = 0;
if (width < 0) {
flags['-'] = 1;
width = -width;
}
if (precision >= 0)
flags['0'] = 0;
if (precision >= 0 && precision < len)
len = precision;
if (!flags['-'])
pad(width - len, ' ');
{
int i;
for (i = 0; i < len; i++)
put((unsigned char)*str++, cl);
}
if ( flags['-'])
pad(width - len, ' ');
}
void Fmt_fmt(int put(int c, void *), void *cl,
const char *fmt, ...) {
va_list_box box;
va_start(box.ap, fmt);
Fmt_vfmt(put, cl, fmt, &box);
va_end(box.ap);
}
void Fmt_print(const char *fmt, ...) {
va_list_box box;
va_start(box.ap, fmt);
Fmt_vfmt(outc, stdout, fmt, &box);
va_end(box.ap);
}
void Fmt_fprint(FILE *stream, const char *fmt, ...) {
va_list_box box;
va_start(box.ap, fmt);
Fmt_vfmt(outc, stream, fmt, &box);
va_end(box.ap);
}
int Fmt_sfmt(char *buf, int size, const char *fmt, ...) {
int len;
va_list_box box;
va_start(box.ap, fmt);
len = Fmt_vsfmt(buf, size, fmt, &box);
va_end(box.ap);
return len;
}
int Fmt_vsfmt(char *buf, int size, const char *fmt,
va_list_box *box) {
struct buf cl;
assert(buf);
assert(size > 0);
assert(fmt);
cl.buf = cl.bp = buf;
cl.size = size;
Fmt_vfmt(insert, &cl, fmt, box);
insert(0, &cl);
return cl.bp - cl.buf - 1;
}
char *Fmt_string(const char *fmt, ...) {
char *str;
va_list_box box;
assert(fmt);
va_start(box.ap, fmt);
str = Fmt_vstring(fmt, &box);
va_end(box.ap);
return str;
}
char *Fmt_vstring(const char *fmt, va_list_box *box) {
struct buf cl;
assert(fmt);
cl.size = 256;
cl.buf = cl.bp = ALLOC(cl.size);
Fmt_vfmt(append, &cl, fmt, box);
append(0, &cl);
return RESIZE(cl.buf, cl.bp - cl.buf);
}
void Fmt_vfmt(int put(int c, void *cl), void *cl,
const char *fmt, va_list_box *box) {
assert(put);
assert(fmt);
while (*fmt)
if (*fmt != '%' || *++fmt == '%')
put((unsigned char)*fmt++, cl);
else
{
unsigned char c, flags[256];
int width = INT_MIN, precision = INT_MIN;
memset(flags, '\0', sizeof flags);
if (Fmt_flags) {
unsigned char c = *fmt;
for ( ; c && strchr(Fmt_flags, c); c = *++fmt) {
assert(flags[c] < 255);
flags[c]++;
}
}
if (*fmt == '*' || isdigit(*fmt)) {
int n;
if (*fmt == '*') {
n = va_arg(box->ap, int);
assert(n != INT_MIN);
fmt++;
} else
for (n = 0; isdigit(*fmt); fmt++) {
int d = *fmt - '0';
assert(n <= (INT_MAX - d)/10);
n = 10*n + d;
}
width = n;
}
if (*fmt == '.' && (*++fmt == '*' || isdigit(*fmt))) {
int n;
if (*fmt == '*') {
n = va_arg(box->ap, int);
assert(n != INT_MIN);
fmt++;
} else
for (n = 0; isdigit(*fmt); fmt++) {
int d = *fmt - '0';
assert(n <= (INT_MAX - d)/10);
n = 10*n + d;
}
precision = n;
}
c = *fmt++;
assert(cvt[c]);
(*cvt[c])(c, box, put, cl, flags, width, precision);
}
}
T Fmt_register(int code, T newcvt) {
T old;
assert(0 < code
&& code < (int)(sizeof (cvt)/sizeof (cvt[0])));
old = cvt[code];
cvt[code] = newcvt;
return old;
}
void Fmt_putd(const char *str, int len,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
int sign;
assert(str);
assert(len >= 0);
assert(flags);
if (width == INT_MIN)
width = 0;
if (width < 0) {
flags['-'] = 1;
width = -width;
}
if (precision >= 0)
flags['0'] = 0;
if (len > 0 && (*str == '-' || *str == '+')) {
sign = *str++;
len--;
} else if (flags['+'])
sign = '+';
else if (flags[' '])
sign = ' ';
else
sign = 0;
{ int n;
if (precision < 0)
precision = 1;
if (len < precision)
n = precision;
else if (precision == 0 && len == 1 && str[0] == '0')
n = 0;
else
n = len;
if (sign)
n++;
if (flags['-']) {
if (sign)
put(sign, cl);
} else if (flags['0']) {
if (sign)
put(sign, cl);
pad(width - n, '0');
} else {
pad(width - n, ' ');
if (sign)
put(sign, cl);
}
pad(precision - len, '0');
{
int i;
for (i = 0; i < len; i++)
put((unsigned char)*str++, cl);
}
if (flags['-'])
pad(width - n, ' '); }
}
eisl-5.55/cii/src/libcii.def 0000664 0000000 0000000 00000006054 15066676224 0015675 0 ustar 00root root 0000000 0000000 ; $Id$
LIBRARY libcii
DESCRIPTION "C Interfaces and Implementations 1.0"
EXPORTS
AP_new
AP_fromstr
AP_toint
AP_tostr
AP_fmt
AP_free
AP_neg
AP_add
AP_sub
AP_mul
AP_div
AP_mod
AP_pow
AP_addi
AP_subi
AP_muli
AP_divi
AP_modi
AP_lshift
AP_rshift
AP_cmp
AP_cmpi
Arena_NewFailed
Arena_Failed
Arena_new
Arena_dispose
Arena_alloc
Arena_calloc
Arena_free
Arith_max
Arith_min
Arith_div
Arith_mod
Arith_ceiling
Arith_floor
Array_new
Array_free
Array_length
Array_size
Array_get
Array_put
Array_resize
Array_copy
ArrayRep_init
Atom_length
Atom_new
Atom_string
Atom_int
Bit_new
Bit_length
Bit_count
Bit_free
Bit_get
Bit_put
Bit_clear
Bit_set
Bit_not
Bit_lt
Bit_eq
Bit_leq
Bit_map
Bit_union
Bit_inter
Bit_minus
Bit_diff
Chan_new
Chan_send
Chan_receive
Except_stack
Except_raise
Assert_Failed
Fmt_flags
Fmt_Overflow
Fmt_fmt
Fmt_vfmt
Fmt_print
Fmt_fprint
Fmt_sfmt
Fmt_vsfmt
Fmt_string
Fmt_vstring
Fmt_register
Fmt_putd
Fmt_puts
List_append
List_copy
List_list
List_pop
List_push
List_reverse
List_length
List_free
List_map
List_toArray
Mem_Failed
Mem_alloc
Mem_calloc
Mem_free
Mem_resize
MP_Overflow
MP_Dividebyzero
MP_set
MP_new
MP_fromint
MP_fromintu
MP_tointu
MP_toint
MP_cvt
MP_cvtu
MP_add
MP_sub
MP_mul
MP_div
MP_mod
MP_neg
MP_addu
MP_subu
MP_mulu
MP_divu
MP_modu
MP_mul2u
MP_mul2
MP_addi
MP_subi
MP_muli
MP_divi
MP_addui
MP_subui
MP_mului
MP_divui
MP_modi
MP_modui
MP_cmp
MP_cmpi
MP_cmpu
MP_cmpui
MP_and
MP_or
MP_xor
MP_not
MP_andi
MP_ori
MP_xori
MP_lshift
MP_rshift
MP_ashift
MP_fromstr
MP_tostr
MP_fmt
MP_fmtu
Ring_new
Ring_ring
Ring_free
Ring_length
Ring_get
Ring_put
Ring_add
Ring_addlo
Ring_addhi
Ring_remove
Ring_remlo
Ring_remhi
Ring_rotate
Sem_init
Sem_new
Sem_wait
Sem_signal
Seq_new
Seq_seq
Seq_free
Seq_length
Seq_get
Seq_put
Seq_addlo
Seq_addhi
Seq_remlo
Seq_remhi
Set_new
Set_free
Set_length
Set_member
Set_put
Set_remove
Set_map
Set_toArray
Set_union
Set_inter
Set_minus
Set_diff
Stack_new
Stack_empty
Stack_push
Stack_pop
Stack_free
Str_sub
Str_dup
Str_cat
Str_catv
Str_reverse
Str_map
Str_pos
Str_len
Str_cmp
Str_chr
Str_rchr
Str_upto
Str_rupto
Str_find
Str_rfind
Str_any
Str_many
Str_rmany
Str_match
Str_rmatch
Str_fmt
Table_new
Table_free
Table_length
Table_put
Table_get
Table_remove
Table_map
Table_toArray
Text_cset
Text_ascii
Text_ucase
Text_lcase
Text_digits
Text_null
Text_put
Text_get
Text_box
Text_sub
Text_pos
Text_cat
Text_dup
Text_reverse
Text_map
Text_cmp
Text_chr
Text_rchr
Text_upto
Text_rupto
Text_any
Text_many
Text_rmany
Text_find
Text_rfind
Text_match
Text_rmatch
Text_fmt
Text_save
Text_restore
Thread_Failed
Thread_Alerted
Thread_init
Thread_new
Thread_exit
Thread_alert
Thread_self
Thread_join
Thread_pause
XP_add
XP_sub
XP_mul
XP_div
XP_sum
XP_diff
XP_product
XP_quotient
XP_neg
XP_cmp
XP_lshift
XP_rshift
XP_length
XP_fromint
XP_toint
XP_fromstr
XP_tostr
Except_init
Except_index
Except_push
Except_pop
eisl-5.55/cii/src/list.c 0000664 0000000 0000000 00000003123 15066676224 0015073 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include
#include "assert.h"
#include "mem.h"
#include "list.h"
#define T List_T
T List_push(T list, void *x) {
T p;
NEW(p);
p->first = x;
p->rest = list;
return p;
}
T List_list(void *x, ...) {
va_list ap;
T list, *p = &list;
va_start(ap, x);
for ( ; x; x = va_arg(ap, void *)) {
NEW(*p);
(*p)->first = x;
p = &(*p)->rest;
}
*p = NULL;
va_end(ap);
return list;
}
T List_append(T list, T tail) {
T *p = &list;
while (*p)
p = &(*p)->rest;
*p = tail;
return list;
}
T List_copy(T list) {
T head, *p = &head;
for ( ; list; list = list->rest) {
NEW(*p);
(*p)->first = list->first;
p = &(*p)->rest;
}
*p = NULL;
return head;
}
T List_pop(T list, void **x) {
if (list) {
T head = list->rest;
if (x)
*x = list->first;
FREE(list);
return head;
} else
return list;
}
T List_reverse(T list) {
T head = NULL, next;
for ( ; list; list = next) {
next = list->rest;
list->rest = head;
head = list;
}
return head;
}
int List_length(T list) {
int n;
for (n = 0; list; list = list->rest)
n++;
return n;
}
void List_free(T *list) {
T next;
assert(list);
for ( ; *list; *list = next) {
next = (*list)->rest;
FREE(*list);
}
}
void List_map(T list,
void apply(void **x, void *cl), void *cl) {
assert(apply);
for ( ; list; list = list->rest)
apply(&list->first, cl);
}
void **List_toArray(T list, void *end) {
int i, n = List_length(list);
void **array = ALLOC((n + 1)*sizeof (*array));
for (i = 0; i < n; i++) {
array[i] = list->first;
list = list->rest;
}
array[i] = end;
return array;
}
eisl-5.55/cii/src/mem.c 0000664 0000000 0000000 00000002066 15066676224 0014703 0 ustar 00root root 0000000 0000000 //static char rcsid[] = "$Id$";
#include
#include
#include "assert.h"
#include "except.h"
#include "mem.h"
const Except_T Mem_Failed = { "Allocation failed" };
void *Mem_alloc(long nbytes, const char *file, int line){
void *ptr;
assert(nbytes > 0);
ptr = malloc(nbytes);
if (ptr == NULL)
{
if (file == NULL)
RAISE(Mem_Failed);
else
Except_raise(&Mem_Failed, file, line);
}
return ptr;
}
void *Mem_calloc(long count, long nbytes,
const char *file, int line) {
void *ptr;
assert(count > 0);
assert(nbytes > 0);
ptr = calloc(count, nbytes);
if (ptr == NULL)
{
if (file == NULL)
RAISE(Mem_Failed);
else
Except_raise(&Mem_Failed, file, line);
}
return ptr;
}
void Mem_free(void *ptr, const char *file , int line ) {
if (ptr)
free(ptr);
}
void *Mem_resize(void *ptr, long nbytes,
const char *file, int line) {
assert(ptr);
assert(nbytes > 0);
ptr = realloc(ptr, nbytes);
if (ptr == NULL)
{
if (file == NULL)
RAISE(Mem_Failed);
else
Except_raise(&Mem_Failed, file, line);
}
return ptr;
}
eisl-5.55/cii/src/memchk.c 0000664 0000000 0000000 00000006335 15066676224 0015374 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include
#include "assert.h"
#include "except.h"
#include "mem.h"
union align {
#ifdef MAXALIGN
char pad[MAXALIGN];
#else
int i;
long l;
long *lp;
void *p;
void (*fp)(void);
float f;
double d;
long double ld;
#endif
};
#define hash(p, t) (((unsigned long)(p)>>3) & \
(sizeof (t)/sizeof ((t)[0])-1))
#define NDESCRIPTORS 512
#define NALLOC ((4096 + sizeof (union align) - 1)/ \
(sizeof (union align)))*(sizeof (union align))
const Except_T Mem_Failed = { "Allocation failed" };
static struct descriptor {
struct descriptor *free;
struct descriptor *link;
const void *ptr;
long size;
const char *file;
int line;
} *htab[2048];
static struct descriptor freelist = { &freelist };
static struct descriptor *find(const void *ptr) {
struct descriptor *bp = htab[hash(ptr, htab)];
while (bp && bp->ptr != ptr)
bp = bp->link;
return bp;
}
void Mem_free(void *ptr, const char *file, int line) {
if (ptr) {
struct descriptor *bp;
if (((unsigned long)ptr)%(sizeof (union align)) != 0
|| (bp = find(ptr)) == NULL || bp->free)
Except_raise(&Assert_Failed, file, line);
bp->free = freelist.free;
freelist.free = bp;
}
}
void *Mem_resize(void *ptr, long nbytes,
const char *file, int line) {
struct descriptor *bp;
void *newptr;
assert(ptr);
assert(nbytes > 0);
if (((unsigned long)ptr)%(sizeof (union align)) != 0
|| (bp = find(ptr)) == NULL || bp->free)
Except_raise(&Assert_Failed, file, line);
newptr = Mem_alloc(nbytes, file, line);
memcpy(newptr, ptr,
nbytes < bp->size ? nbytes : bp->size);
Mem_free(ptr, file, line);
return newptr;
}
void *Mem_calloc(long count, long nbytes,
const char *file, int line) {
void *ptr;
assert(count > 0);
assert(nbytes > 0);
ptr = Mem_alloc(count*nbytes, file, line);
memset(ptr, '\0', count*nbytes);
return ptr;
}
static struct descriptor *dalloc(void *ptr, long size,
const char *file, int line) {
static struct descriptor *avail;
static int nleft;
if (nleft <= 0) {
avail = malloc(NDESCRIPTORS*sizeof (*avail));
if (avail == NULL)
return NULL;
nleft = NDESCRIPTORS;
}
avail->ptr = ptr;
avail->size = size;
avail->file = file;
avail->line = line;
avail->free = avail->link = NULL;
nleft--;
return avail++;
}
void *Mem_alloc(long nbytes, const char *file, int line){
struct descriptor *bp;
void *ptr;
assert(nbytes > 0);
nbytes = ((nbytes + sizeof (union align) - 1)/
(sizeof (union align)))*(sizeof (union align));
for (bp = freelist.free; bp; bp = bp->free) {
if (bp->size > nbytes) {
bp->size -= nbytes;
ptr = (char *)bp->ptr + bp->size;
if ((bp = dalloc(ptr, nbytes, file, line)) != NULL) {
unsigned h = hash(ptr, htab);
bp->link = htab[h];
htab[h] = bp;
return ptr;
} else
{
if (file == NULL)
RAISE(Mem_Failed);
else
Except_raise(&Mem_Failed, file, line);
}
}
if (bp == &freelist) {
struct descriptor *newptr;
if ((ptr = malloc(nbytes + NALLOC)) == NULL
|| (newptr = dalloc(ptr, nbytes + NALLOC,
__FILE__, __LINE__)) == NULL)
{
if (file == NULL)
RAISE(Mem_Failed);
else
Except_raise(&Mem_Failed, file, line);
}
newptr->free = freelist.free;
freelist.free = newptr;
}
}
assert(0);
return NULL;
}
eisl-5.55/cii/src/memcmp.c 0000664 0000000 0000000 00000000553 15066676224 0015402 0 ustar 00root root 0000000 0000000 #include
/*lint -e613
memcmp is defined here because some vendors don't implement
it, strcmp, or strncmp correctly; they must treat the bytes
as unsigned chars.
*/
int memcmp(const void *s1, const void *s2, size_t n) {
const unsigned char *cs1 = s1, *cs2 = s2;
for ( ; n-- > 0; cs1++, cs2++)
if (*cs1 != *cs2)
return *cs1 - *cs2;
return 0;
}
eisl-5.55/cii/src/memmove.c 0000664 0000000 0000000 00000000676 15066676224 0015577 0 ustar 00root root 0000000 0000000 #include
/*lint -e613
memmove is defined here because some vendors don't provide it at all
and others do poor job (like calling malloc)
*/
void *memmove(void *s1, const void *s2, size_t n) {
unsigned char *cs1;
const unsigned char *cs2;
if (n <= 0)
return s1;
cs1 = s1;
cs2 = s2;
if (cs1 < cs2)
do
*cs1++ = *cs2++;
while (--n);
else {
cs1 += n;
cs2 += n;
do
*--cs1 = *--cs2;
while (--n);
}
return s1;
}
eisl-5.55/cii/src/mp.c 0000664 0000000 0000000 00000036211 15066676224 0014540 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include
#include
#include
#include
#include "assert.h"
#include "fmt.h"
#include "mem.h"
#include "xp.h"
#include "mp.h"
#define T MP_T
#define sign(x) ((x)[nbytes-1]>>shift)
#define ones(n) (~(~0UL<<(((n)-1)%8+1)))
#define iszero(x) (XP_length(nbytes,(x))==1 && (x)[0]==0)
#define BASE (1<<8)
#define bitop(op) \
int i; assert(z); assert(x); assert(y); \
for (i = 0; i < nbytes; i++) z[i] = x[i] op y[i]; \
return z
#define bitopi(op) assert(z); assert(x); \
applyu(op, z, x, y); \
return z
#define shft(fill, op) \
assert(x); assert(z); assert(s >= 0); \
if (s >= nbits) memset(z, fill, nbytes); \
else op(nbytes, z, nbytes, x, s, fill); \
z[nbytes-1] &= msb; \
return z
const Except_T MP_Dividebyzero = { "Division by zero" };
const Except_T MP_Overflow = { "Overflow" };
static int nbits = 32;
static int nbytes = (32-1)/8 + 1;
static int shift = (32-1)%8;
static unsigned char msb = 0xFF;
static unsigned char temp[16 + 16 + 16 + 2*16+2];
static T tmp[] = {temp, temp+1*16, temp+2*16, temp+3*16};
static int applyu(T op(T, T, T), T z, T x,
unsigned long u) {
unsigned long carry;
{ T z = tmp[2]; carry = XP_fromint(nbytes, z, u);
carry |= z[nbytes-1]&~msb;
z[nbytes-1] &= msb; }
op(z, x, tmp[2]);
return carry != 0;
}
static int apply(T op(T, T, T), T z, T x, long v) {
{ T z = tmp[2]; if (v == LONG_MIN) {
XP_fromint(nbytes, z, LONG_MAX + 1UL);
XP_neg(nbytes, z, z, 1);
} else if (v < 0) {
XP_fromint(nbytes, z, -v);
XP_neg(nbytes, z, z, 1);
} else
XP_fromint(nbytes, z, v);
z[nbytes-1] &= msb; }
op(z, x, tmp[2]);
return (nbits < 8*(int)sizeof (v) &&
(v < -(1L<<(nbits-1)) || v >= (1L<<(nbits-1))));
}
int MP_set(int n) {
int prev = nbits;
assert(n > 1);
nbits = n;
nbytes = (n-1)/8 + 1;
shift = (n-1)%8;
msb = ones(n);
if (tmp[0] != temp)
FREE(tmp[0]);
if (nbytes <= 16)
tmp[0] = temp;
else
tmp[0] = ALLOC(3*nbytes + 2*nbytes + 2);
tmp[1] = tmp[0] + 1*nbytes;
tmp[2] = tmp[0] + 2*nbytes;
tmp[3] = tmp[0] + 3*nbytes;
return prev;
}
T MP_new(unsigned long u) {
return MP_fromintu(ALLOC(nbytes), u);
}
T MP_fromintu(T z, unsigned long u) {
unsigned long carry;
assert(z);
carry = XP_fromint(nbytes, z, u);
carry |= z[nbytes-1]&~msb;
z[nbytes-1] &= msb;
if (carry)
RAISE(MP_Overflow);
return z;
}
T MP_fromint(T z, long v) {
assert(z);
if (v == LONG_MIN) {
XP_fromint(nbytes, z, LONG_MAX + 1UL);
XP_neg(nbytes, z, z, 1);
} else if (v < 0) {
XP_fromint(nbytes, z, -v);
XP_neg(nbytes, z, z, 1);
} else
XP_fromint(nbytes, z, v);
z[nbytes-1] &= msb;
if ((nbits < 8*(int)sizeof (v) &&
(v < -(1L<<(nbits-1)) || v >= (1L<<(nbits-1)))))
RAISE(MP_Overflow);
return z;
}
long MP_toint(T x) {
unsigned char d[sizeof (unsigned long)];
assert(x);
MP_cvt(8*sizeof d, d, x);
return XP_toint(sizeof d, d);
}
T MP_cvt(int m, T z, T x) {
int fill, i, mbytes = (m - 1)/8 + 1;
assert(m > 1);
assert(x); assert(z);
fill = sign(x) ? 0xFF : 0;
if (m < nbits) {
int carry = (x[mbytes-1]^fill)&~ones(m);
for (i = mbytes; i < nbytes; i++)
carry |= x[i]^fill;
memcpy(z, x, mbytes);
z[mbytes-1] &= ones(m);
if (carry)
RAISE(MP_Overflow);
} else {
memcpy(z, x, nbytes);
z[nbytes-1] |= fill&~msb;
for (i = nbytes; i < mbytes; i++)
z[i] = fill;
z[mbytes-1] &= ones(m);
}
return z;
}
unsigned long MP_tointu(T x) {
unsigned char d[sizeof (unsigned long)];
assert(x);
MP_cvtu(8*sizeof d, d, x);
return XP_toint(sizeof d, d);
}
T MP_cvtu(int m, T z, T x) {
int i, mbytes = (m - 1)/8 + 1;
assert(m > 1);
assert(x); assert(z);
if (m < nbits) {
int carry = x[mbytes-1]&~ones(m);
for (i = mbytes; i < nbytes; i++)
carry |= x[i];
memcpy(z, x, mbytes);
z[mbytes-1] &= ones(m);
if (carry)
RAISE(MP_Overflow);
} else {
memcpy(z, x, nbytes);
for (i = nbytes; i < mbytes; i++)
z[i] = 0;
}
return z;
}
T MP_addu(T z, T x, T y) {
int carry;
assert(x); assert(y); assert(z);
carry = XP_add(nbytes, z, x, y, 0);
carry |= z[nbytes-1]&~msb;
z[nbytes-1] &= msb;
if (carry)
RAISE(MP_Overflow);
return z;
}
T MP_subu(T z, T x, T y) {
int borrow;
assert(x); assert(y); assert(z);
borrow = XP_sub(nbytes, z, x, y, 0);
borrow |= z[nbytes-1]&~msb;
z[nbytes-1] &= msb;
if (borrow)
RAISE(MP_Overflow);
return z;
}
T MP_mul2u(T z, T x, T y) {
assert(x); assert(y); assert(z);
memset(tmp[3], '\0', 2*nbytes);
XP_mul(tmp[3], nbytes, x, nbytes, y);
memcpy(z, tmp[3], (2*nbits - 1)/8 + 1);
return z;
}
T MP_mulu(T z, T x, T y) {
assert(x); assert(y); assert(z);
memset(tmp[3], '\0', 2*nbytes);
XP_mul(tmp[3], nbytes, x, nbytes, y);
memcpy(z, tmp[3], nbytes);
z[nbytes-1] &= msb;
{
int i;
if (tmp[3][nbytes-1]&~msb)
RAISE(MP_Overflow);
for (i = 0; i < nbytes; i++)
if (tmp[3][i+nbytes] != 0)
RAISE(MP_Overflow);
}
return z;
}
T MP_divu(T z, T x, T y) {
assert(x); assert(y); assert(z);
{
memcpy(tmp[1], y, nbytes);
y = tmp[1];
}
if (!XP_div(nbytes, z, x, nbytes, y, tmp[2], tmp[3]))
RAISE(MP_Dividebyzero);
return z;
}
T MP_modu(T z, T x, T y) {
assert(x); assert(y); assert(z);
{
memcpy(tmp[1], y, nbytes);
y = tmp[1];
}
if (!XP_div(nbytes, tmp[2], x, nbytes, y, z, tmp[3]))
RAISE(MP_Dividebyzero);
return z;
}
T MP_add(T z, T x, T y) {
int sx, sy;
assert(x); assert(y); assert(z);
sx = sign(x);
sy = sign(y);
XP_add(nbytes, z, x, y, 0);
z[nbytes-1] &= msb;
if (sx == sy && sy != sign(z))
RAISE(MP_Overflow);
return z;
}
T MP_sub(T z, T x, T y) {
int sx, sy;
assert(x); assert(y); assert(z);
sx = sign(x);
sy = sign(y);
XP_sub(nbytes, z, x, y, 0);
z[nbytes-1] &= msb;
if (sx != sy && sy == sign(z))
RAISE(MP_Overflow);
return z;
}
T MP_neg(T z, T x) {
int sx;
assert(x); assert(z);
sx = sign(x);
XP_neg(nbytes, z, x, 1);
z[nbytes-1] &= msb;
if (sx && sx == sign(z))
RAISE(MP_Overflow);
return z;
}
T MP_mul2(T z, T x, T y) {
int sx, sy;
assert(x); assert(y); assert(z);
sx = sign(x);
sy = sign(y);
if (sx) {
XP_neg(nbytes, tmp[0], x, 1);
x = tmp[0];
x[nbytes-1] &= msb;
}
if (sy) {
XP_neg(nbytes, tmp[1], y, 1);
y = tmp[1];
y[nbytes-1] &= msb;
}
memset(tmp[3], '\0', 2*nbytes);
XP_mul(tmp[3], nbytes, x, nbytes, y);
if (sx != sy)
XP_neg((2*nbits - 1)/8 + 1, z, tmp[3], 1);
else
memcpy(z, tmp[3], (2*nbits - 1)/8 + 1);
return z;
}
T MP_mul(T z, T x, T y) {
int sx, sy;
assert(x); assert(y); assert(z);
sx = sign(x);
sy = sign(y);
if (sx) {
XP_neg(nbytes, tmp[0], x, 1);
x = tmp[0];
x[nbytes-1] &= msb;
}
if (sy) {
XP_neg(nbytes, tmp[1], y, 1);
y = tmp[1];
y[nbytes-1] &= msb;
}
memset(tmp[3], '\0', 2*nbytes);
XP_mul(tmp[3], nbytes, x, nbytes, y);
if (sx != sy)
XP_neg(nbytes, z, tmp[3], 1);
else
memcpy(z, tmp[3], nbytes);
z[nbytes-1] &= msb;
{
int i;
if (tmp[3][nbytes-1]&~msb)
RAISE(MP_Overflow);
for (i = 0; i < nbytes; i++)
if (tmp[3][i+nbytes] != 0)
RAISE(MP_Overflow);
}
if (sx == sy && sign(z))
RAISE(MP_Overflow);
return z;
}
T MP_div(T z, T x, T y) {
int sx, sy;
assert(x); assert(y); assert(z);
sx = sign(x);
sy = sign(y);
if (sx) {
XP_neg(nbytes, tmp[0], x, 1);
x = tmp[0];
x[nbytes-1] &= msb;
}
if (sy) {
XP_neg(nbytes, tmp[1], y, 1);
y = tmp[1];
y[nbytes-1] &= msb;
} else {
memcpy(tmp[1], y, nbytes);
y = tmp[1];
}
if (!XP_div(nbytes, z, x, nbytes, y, tmp[2], tmp[3]))
RAISE(MP_Dividebyzero);
if (sx != sy) {
XP_neg(nbytes, z, z, 1);
if (!iszero(tmp[2]))
XP_diff(nbytes, z, z, 1);
z[nbytes-1] &= msb;
} else if (sx && sign(z))
RAISE(MP_Overflow);
return z;
}
T MP_mod(T z, T x, T y) {
int sx, sy;
assert(x); assert(y); assert(z);
sx = sign(x);
sy = sign(y);
if (sx) {
XP_neg(nbytes, tmp[0], x, 1);
x = tmp[0];
x[nbytes-1] &= msb;
}
if (sy) {
XP_neg(nbytes, tmp[1], y, 1);
y = tmp[1];
y[nbytes-1] &= msb;
} else {
memcpy(tmp[1], y, nbytes);
y = tmp[1];
}
if (!XP_div(nbytes, tmp[2], x, nbytes, y, z, tmp[3]))
RAISE(MP_Dividebyzero);
if (sx != sy) {
if (!iszero(z))
XP_sub(nbytes, z, y, z, 0);
} else if (sx && sign(tmp[2]))
RAISE(MP_Overflow);
return z;
}
T MP_addui(T z, T x, unsigned long y) {
assert(x); assert(z);
if (y < BASE) {
int carry = XP_sum(nbytes, z, x, y);
carry |= z[nbytes-1]&~msb;
z[nbytes-1] &= msb;
if (carry)
RAISE(MP_Overflow);
} else if (applyu(MP_addu, z, x, y))
RAISE(MP_Overflow);
return z;
}
T MP_subui(T z, T x, unsigned long y) {
assert(x); assert(z);
if (y < BASE) {
int borrow = XP_diff(nbytes, z, x, y);
borrow |= z[nbytes-1]&~msb;
z[nbytes-1] &= msb;
if (borrow)
RAISE(MP_Overflow);
} else if (applyu(MP_subu, z, x, y))
RAISE(MP_Overflow);
return z;
}
T MP_mului(T z, T x, unsigned long y) {
assert(x); assert(z);
if (y < BASE) {
int carry = XP_product(nbytes, z, x, y);
carry |= z[nbytes-1]&~msb;
z[nbytes-1] &= msb;
if (carry)
RAISE(MP_Overflow);
if (nbits < 8 && y >= (1U<= (1U<= (1U<= (1<<(nbits-1))))
RAISE(MP_Overflow);
} else if (apply(MP_add, z, x, y))
RAISE(MP_Overflow);
return z;
}
T MP_subi(T z, T x, long y) {
assert(x); assert(z);
if (-BASE < y && y < BASE) {
int sx = sign(x), sy = y < 0;
if (sy)
XP_sum (nbytes, z, x, -y);
else
XP_diff(nbytes, z, x, y);
z[nbytes-1] &= msb;
if (sx != sy && sy == sign(z))
RAISE(MP_Overflow);
if (nbits < 8
&& (y < -(1<<(nbits-1)) || y >= (1<<(nbits-1))))
RAISE(MP_Overflow);
} else if (apply(MP_sub, z, x, y))
RAISE(MP_Overflow);
return z;
}
T MP_muli(T z, T x, long y) {
assert(x); assert(z);
if (-BASE < y && y < BASE) {
int sx = sign(x), sy = y < 0;
if (sx) {
XP_neg(nbytes, tmp[0], x, 1);
x = tmp[0];
x[nbytes-1] &= msb;
}
XP_product(nbytes, z, x, sy ? -y : y);
if (sx != sy)
XP_neg(nbytes, z, x, 1);
z[nbytes-1] &= msb;
if (sx == sy && sign(z))
RAISE(MP_Overflow);
if (nbits < 8
&& (y < -(1<<(nbits-1)) || y >= (1<<(nbits-1))))
RAISE(MP_Overflow);
} else if (apply(MP_mul, z, x, y))
RAISE(MP_Overflow);
return z;
}
T MP_divi(T z, T x, long y) {
assert(x); assert(z);
if (y == 0)
RAISE(MP_Dividebyzero);
else if (-BASE < y && y < BASE) {
int r;
int sx = sign(x), sy = y < 0;
if (sx) {
XP_neg(nbytes, tmp[0], x, 1);
x = tmp[0];
x[nbytes-1] &= msb;
}
r = XP_quotient(nbytes, z, x, sy ? -y : y);
if (sx != sy) {
XP_neg(nbytes, z, z, 1);
if (r != 0) {
XP_diff(nbytes, z, z, 1);
r = y - r;
}
z[nbytes-1] &= msb;
} else if (sx && sign(z))
RAISE(MP_Overflow);
if (nbits < 8
&& (y < -(1<<(nbits-1)) || y >= (1<<(nbits-1))))
RAISE(MP_Overflow);
} else if (apply(MP_div, z, x, y))
RAISE(MP_Overflow);
return z;
}
long MP_modi(T x, long y) {
assert(x);
if (y == 0)
RAISE(MP_Dividebyzero);
else if (-BASE < y && y < BASE) {
T z = tmp[2];
int r;
int sx = sign(x), sy = y < 0;
if (sx) {
XP_neg(nbytes, tmp[0], x, 1);
x = tmp[0];
x[nbytes-1] &= msb;
}
r = XP_quotient(nbytes, z, x, sy ? -y : y);
if (sx != sy) {
XP_neg(nbytes, z, z, 1);
if (r != 0) {
XP_diff(nbytes, z, z, 1);
r = y - r;
}
z[nbytes-1] &= msb;
} else if (sx && sign(z))
RAISE(MP_Overflow);
if (nbits < 8
&& (y < -(1<<(nbits-1)) || y >= (1<<(nbits-1))))
RAISE(MP_Overflow);
return r;
} else if (apply(MP_mod, tmp[2], x, y))
RAISE(MP_Overflow);
return MP_toint(tmp[2]);
}
int MP_cmpu(T x, T y) {
assert(x);
assert(y);
return XP_cmp(nbytes, x, y);
}
int MP_cmp(T x, T y) {
int sx, sy;
assert(x);
assert(y);
sx = sign(x);
sy = sign(y);
if (sx != sy)
return sy - sx;
else
return XP_cmp(nbytes, x, y);
}
int MP_cmpui(T x, unsigned long y) {
assert(x);
if ((int)sizeof y >= nbytes) {
unsigned long v = XP_toint(nbytes, x);
if (v < y)
return -1;
else if (v > y)
return 1;
else
return 0;
} else {
XP_fromint(nbytes, tmp[2], y);
return XP_cmp(nbytes, x, tmp[2]);
}
}
int MP_cmpi(T x, long y) {
int sx, sy = y < 0;
assert(x);
sx = sign(x);
if (sx != sy)
return sy - sx;
else if ((int)sizeof y >= nbytes) {
long v = MP_toint(x);
if (v < y)
return -1;
else if (v > y)
return 1;
else
return 0;
} else {
MP_fromint(tmp[2], y);
return XP_cmp(nbytes, x, tmp[2]);
}
}
T MP_and(T z, T x, T y) { bitop(&); }
T MP_or (T z, T x, T y) { bitop(|); }
T MP_xor(T z, T x, T y) { bitop(^); }
T MP_not(T z, T x) {
int i;
assert(x); assert(z);
for (i = 0; i < nbytes; i++)
z[i] = ~x[i];
z[nbytes-1] &= msb;
return z;
}
T MP_andi(T z, T x, unsigned long y) { bitopi(MP_and); }
T MP_ori (T z, T x, unsigned long y) { bitopi(MP_or); }
T MP_xori(T z, T x, unsigned long y) { bitopi(MP_xor); }
T MP_lshift(T z, T x, int s) { shft(0, XP_lshift); }
T MP_rshift(T z, T x, int s) { shft(0, XP_rshift); }
T MP_ashift(T z, T x, int s) { shft(sign(x),XP_rshift); }
T MP_fromstr(T z, const char *str, int base, char **end){
int carry;
assert(z);
memset(z, '\0', nbytes);
carry = XP_fromstr(nbytes, z, str, base, end);
carry |= z[nbytes-1]&~msb;
z[nbytes-1] &= msb;
if (carry)
RAISE(MP_Overflow);
return z;
}
char *MP_tostr(char *str, int size, int base, T x) {
assert(x);
assert(base >= 2 && base <= 36);
assert(str == NULL || size > 1);
if (str == NULL) {
{
int k;
for (k = 5; (1< base; k--)
;
size = nbits/k + 1 + 1;
}
str = ALLOC(size);
}
memcpy(tmp[1], x, nbytes);
XP_tostr(str, size, base, nbytes, tmp[1]);
return str;
}
void MP_fmtu(int code, va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
T x;
char *buf;
assert(box && flags);
x = va_arg(box->ap, T);
assert(x);
buf = MP_tostr(NULL, 0, va_arg(box->ap, int), x);
Fmt_putd(buf, strlen(buf), put, cl, flags,
width, precision);
FREE(buf);
}
void MP_fmt(int code, va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
T x;
int base, size, sx;
char *buf;
assert(box && flags);
x = va_arg(box->ap, T);
assert(x);
base = va_arg(box->ap, int);
assert(base >= 2 && base <= 36);
sx = sign(x);
if (sx) {
XP_neg(nbytes, tmp[0], x, 1);
x = tmp[0];
x[nbytes-1] &= msb;
}
{
int k;
for (k = 5; (1< base; k--)
;
size = nbits/k + 1 + 1;
}
buf = ALLOC(size+1);
if (sx) {
buf[0] = '-';
MP_tostr(buf + 1, size, base, x);
} else
MP_tostr(buf, size + 1, base, x);
Fmt_putd(buf, strlen(buf), put, cl, flags,
width, precision);
FREE(buf);
}
eisl-5.55/cii/src/ring.c 0000664 0000000 0000000 00000007261 15066676224 0015066 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include
#include
#include "assert.h"
#include "ring.h"
#include "mem.h"
#define T Ring_T
struct T {
struct node {
struct node *llink, *rlink;
void *value;
} *head;
int length;
};
T Ring_new(void) {
T ring;
NEW0(ring);
ring->head = NULL;
return ring;
}
T Ring_ring(void *x, ...) {
va_list ap;
T ring = Ring_new();
va_start(ap, x);
for ( ; x; x = va_arg(ap, void *))
Ring_addhi(ring, x);
va_end(ap);
return ring;
}
void Ring_free(T *ring) {
struct node *p, *q;
assert(ring && *ring);
if ((p = (*ring)->head) != NULL) {
int n = (*ring)->length;
for ( ; n-- > 0; p = q) {
q = p->rlink;
FREE(p);
}
}
FREE(*ring);
}
int Ring_length(T ring) {
assert(ring);
return ring->length;
}
void *Ring_get(T ring, int i) {
struct node *q;
assert(ring);
assert(i >= 0 && i < ring->length);
{
int n;
q = ring->head;
if (i <= ring->length/2)
for (n = i; n-- > 0; )
q = q->rlink;
else
for (n = ring->length - i; n-- > 0; )
q = q->llink;
}
return q->value;
}
void *Ring_put(T ring, int i, void *x) {
struct node *q;
void *prev;
assert(ring);
assert(i >= 0 && i < ring->length);
{
int n;
q = ring->head;
if (i <= ring->length/2)
for (n = i; n-- > 0; )
q = q->rlink;
else
for (n = ring->length - i; n-- > 0; )
q = q->llink;
}
prev = q->value;
q->value = x;
return prev;
}
void *Ring_addhi(T ring, void *x) {
struct node *p, *q;
assert(ring);
NEW(p);
if ((q = ring->head) != NULL)
{
p->llink = q->llink;
q->llink->rlink = p;
p->rlink = q;
q->llink = p;
}
else
ring->head = p->llink = p->rlink = p;
ring->length++;
return p->value = x;
}
void *Ring_addlo(T ring, void *x) {
assert(ring);
Ring_addhi(ring, x);
ring->head = ring->head->llink;
return x;
}
void *Ring_add(T ring, int pos, void *x) {
assert(ring);
assert(pos >= -ring->length && pos<=ring->length+1);
if (pos == 1 || pos == -ring->length)
return Ring_addlo(ring, x);
else if (pos == 0 || pos == ring->length + 1)
return Ring_addhi(ring, x);
else {
struct node *p, *q;
int i = pos < 0 ? pos + ring->length : pos - 1;
{
int n;
q = ring->head;
if (i <= ring->length/2)
for (n = i; n-- > 0; )
q = q->rlink;
else
for (n = ring->length - i; n-- > 0; )
q = q->llink;
}
NEW(p);
{
p->llink = q->llink;
q->llink->rlink = p;
p->rlink = q;
q->llink = p;
}
ring->length++;
return p->value = x;
}
}
void *Ring_remove(T ring, int i) {
void *x;
struct node *q;
assert(ring);
assert(ring->length > 0);
assert(i >= 0 && i < ring->length);
{
int n;
q = ring->head;
if (i <= ring->length/2)
for (n = i; n-- > 0; )
q = q->rlink;
else
for (n = ring->length - i; n-- > 0; )
q = q->llink;
}
if (i == 0)
ring->head = ring->head->rlink;
x = q->value;
q->llink->rlink = q->rlink;
q->rlink->llink = q->llink;
FREE(q);
if (--ring->length == 0)
ring->head = NULL;
return x;
}
void *Ring_remhi(T ring) {
void *x;
struct node *q;
assert(ring);
assert(ring->length > 0);
q = ring->head->llink;
x = q->value;
q->llink->rlink = q->rlink;
q->rlink->llink = q->llink;
FREE(q);
if (--ring->length == 0)
ring->head = NULL;
return x;
}
void *Ring_remlo(T ring) {
assert(ring);
assert(ring->length > 0);
ring->head = ring->head->rlink;
return Ring_remhi(ring);
}
void Ring_rotate(T ring, int n) {
struct node *q;
int i;
assert(ring);
assert(n >= -ring->length && n <= ring->length);
if (n >= 0)
i = n%ring->length;
else
i = n + ring->length;
{
int n;
q = ring->head;
if (i <= ring->length/2)
for (n = i; n-- > 0; )
q = q->rlink;
else
for (n = ring->length - i; n-- > 0; )
q = q->llink;
}
ring->head = q;
}
eisl-5.55/cii/src/seq.c 0000664 0000000 0000000 00000004540 15066676224 0014714 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include
#include
#include "assert.h"
#include "seq.h"
#include "array.h"
#include "arrayrep.h"
#include "mem.h"
#define T Seq_T
struct T {
struct Array_T array;
int length;
int head;
};
static void expand(T seq) {
int n = seq->array.length;
Array_resize(&seq->array, 2*n);
if (seq->head > 0)
{
void **old = &((void **)seq->array.array)[seq->head];
memcpy(old+n, old, (n - seq->head)*sizeof (void *));
seq->head += n;
}
}
T Seq_new(int hint) {
T seq;
assert(hint >= 0);
NEW0(seq);
if (hint == 0)
hint = 16;
ArrayRep_init(&seq->array, hint, sizeof (void *),
ALLOC(hint*sizeof (void *)));
return seq;
}
T Seq_seq(void *x, ...) {
va_list ap;
T seq = Seq_new(0);
va_start(ap, x);
for ( ; x; x = va_arg(ap, void *))
Seq_addhi(seq, x);
va_end(ap);
return seq;
}
void Seq_free(T *seq) {
assert(seq && *seq);
assert((void *)*seq == (void *)&(*seq)->array);
Array_free((Array_T *)seq);
}
int Seq_length(T seq) {
assert(seq);
return seq->length;
}
void *Seq_get(T seq, int i) {
assert(seq);
assert(i >= 0 && i < seq->length);
return ((void **)seq->array.array)[
(seq->head + i)%seq->array.length];
}
void *Seq_put(T seq, int i, void *x) {
void *prev;
assert(seq);
assert(i >= 0 && i < seq->length);
prev = ((void **)seq->array.array)[
(seq->head + i)%seq->array.length];
((void **)seq->array.array)[
(seq->head + i)%seq->array.length] = x;
return prev;
}
void *Seq_remhi(T seq) {
int i;
assert(seq);
assert(seq->length > 0);
i = --seq->length;
return ((void **)seq->array.array)[
(seq->head + i)%seq->array.length];
}
void *Seq_remlo(T seq) {
int i = 0;
void *x;
assert(seq);
assert(seq->length > 0);
x = ((void **)seq->array.array)[
(seq->head + i)%seq->array.length];
seq->head = (seq->head + 1)%seq->array.length;
--seq->length;
return x;
}
void *Seq_addhi(T seq, void *x) {
int i;
assert(seq);
if (seq->length == seq->array.length)
expand(seq);
i = seq->length++;
return ((void **)seq->array.array)[
(seq->head + i)%seq->array.length] = x;
}
void *Seq_addlo(T seq, void *x) {
int i = 0;
assert(seq);
if (seq->length == seq->array.length)
expand(seq);
if (--seq->head < 0)
seq->head = seq->array.length - 1;
seq->length++;
return ((void **)seq->array.array)[
(seq->head + i)%seq->array.length] = x;
}
eisl-5.55/cii/src/set.c 0000664 0000000 0000000 00000014422 15066676224 0014717 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include
#include "mem.h"
#include "assert.h"
#include "arith.h"
#include "set.h"
#define T Set_T
struct T {
int length;
unsigned timestamp;
int (*cmp)(const void *x, const void *y);
unsigned (*hash)(const void *x);
int size;
struct member {
struct member *link;
const void *member;
} **buckets;
};
static int cmpatom(const void *x, const void *y) {
return x != y;
}
static unsigned hashatom(const void *x) {
return (unsigned long)x>>2;
}
static T copy(T t, int hint) {
T set;
assert(t);
set = Set_new(hint, t->cmp, t->hash);
{ int i;
struct member *q;
for (i = 0; i < t->size; i++)
for (q = t->buckets[i]; q; q = q->link)
{
struct member *p;
const void *member = q->member;
int i = (*set->hash)(member)%set->size;
NEW(p);
p->member = member;
p->link = set->buckets[i];
set->buckets[i] = p;
set->length++;
}
}
return set;
}
T Set_new(int hint,
int cmp(const void *x, const void *y),
unsigned hash(const void *x)) {
T set;
int i;
static int primes[] = { 509, 509, 1021, 2053, 4093,
8191, 16381, 32771, 65521, INT_MAX };
assert(hint >= 0);
for (i = 1; primes[i] < hint; i++)
;
set = ALLOC(sizeof (*set) +
primes[i-1]*sizeof (set->buckets[0]));
set->size = primes[i-1];
set->cmp = cmp ? cmp : cmpatom;
set->hash = hash ? hash : hashatom;
set->buckets = (struct member **)(set + 1);
for (i = 0; i < set->size; i++)
set->buckets[i] = NULL;
set->length = 0;
set->timestamp = 0;
return set;
}
int Set_member(T set, const void *member) {
int i;
struct member *p;
assert(set);
assert(member);
i = (*set->hash)(member)%set->size;
for (p = set->buckets[i]; p; p = p->link)
if ((*set->cmp)(member, p->member) == 0)
break;
return p != NULL;
}
void Set_put(T set, const void *member) {
int i;
struct member *p;
assert(set);
assert(member);
i = (*set->hash)(member)%set->size;
for (p = set->buckets[i]; p; p = p->link)
if ((*set->cmp)(member, p->member) == 0)
break;
if (p == NULL) {
NEW(p);
p->member = member;
p->link = set->buckets[i];
set->buckets[i] = p;
set->length++;
} else
p->member = member;
set->timestamp++;
}
void *Set_remove(T set, const void *member) {
int i;
struct member **pp;
assert(set);
assert(member);
set->timestamp++;
i = (*set->hash)(member)%set->size;
for (pp = &set->buckets[i]; *pp; pp = &(*pp)->link)
if ((*set->cmp)(member, (*pp)->member) == 0) {
struct member *p = *pp;
*pp = p->link;
member = p->member;
FREE(p);
set->length--;
return (void *)member;
}
return NULL;
}
int Set_length(T set) {
assert(set);
return set->length;
}
void Set_free(T *set) {
assert(set && *set);
if ((*set)->length > 0) {
int i;
struct member *p, *q;
for (i = 0; i < (*set)->size; i++)
for (p = (*set)->buckets[i]; p; p = q) {
q = p->link;
FREE(p);
}
}
FREE(*set);
}
void Set_map(T set,
void apply(const void *member, void *cl), void *cl) {
int i;
unsigned stamp;
struct member *p;
assert(set);
assert(apply);
stamp = set->timestamp;
for (i = 0; i < set->size; i++)
for (p = set->buckets[i]; p; p = p->link) {
apply(p->member, cl);
assert(set->timestamp == stamp);
}
}
void **Set_toArray(T set, void *end) {
int i, j = 0;
void **array;
struct member *p;
assert(set);
array = ALLOC((set->length + 1)*sizeof (*array));
for (i = 0; i < set->size; i++)
for (p = set->buckets[i]; p; p = p->link)
array[j++] = (void *)p->member;
array[j] = end;
return array;
}
T Set_union(T s, T t) {
if (s == NULL) {
assert(t);
return copy(t, t->size);
} else if (t == NULL)
return copy(s, s->size);
else {
T set = copy(s, Arith_max(s->size, t->size));
assert(s->cmp == t->cmp && s->hash == t->hash);
{ int i;
struct member *q;
for (i = 0; i < t->size; i++)
for (q = t->buckets[i]; q; q = q->link)
Set_put(set, q->member);
}
return set;
}
}
T Set_inter(T s, T t) {
if (s == NULL) {
assert(t);
return Set_new(t->size, t->cmp, t->hash);
} else if (t == NULL)
return Set_new(s->size, s->cmp, s->hash);
else if (s->length < t->length)
return Set_inter(t, s);
else {
T set = Set_new(Arith_min(s->size, t->size),
s->cmp, s->hash);
assert(s->cmp == t->cmp && s->hash == t->hash);
{ int i;
struct member *q;
for (i = 0; i < t->size; i++)
for (q = t->buckets[i]; q; q = q->link)
if (Set_member(s, q->member))
{
struct member *p;
const void *member = q->member;
int i = (*set->hash)(member)%set->size;
NEW(p);
p->member = member;
p->link = set->buckets[i];
set->buckets[i] = p;
set->length++;
}
}
return set;
}
}
T Set_minus(T t, T s) {
if (t == NULL){
assert(s);
return Set_new(s->size, s->cmp, s->hash);
} else if (s == NULL)
return copy(t, t->size);
else {
T set = Set_new(Arith_min(s->size, t->size),
s->cmp, s->hash);
assert(s->cmp == t->cmp && s->hash == t->hash);
{ int i;
struct member *q;
for (i = 0; i < t->size; i++)
for (q = t->buckets[i]; q; q = q->link)
if (!Set_member(s, q->member))
{
struct member *p;
const void *member = q->member;
int i = (*set->hash)(member)%set->size;
NEW(p);
p->member = member;
p->link = set->buckets[i];
set->buckets[i] = p;
set->length++;
}
}
return set;
}
}
T Set_diff(T s, T t) {
if (s == NULL) {
assert(t);
return copy(t, t->size);
} else if (t == NULL)
return copy(s, s->size);
else {
T set = Set_new(Arith_min(s->size, t->size),
s->cmp, s->hash);
assert(s->cmp == t->cmp && s->hash == t->hash);
{ int i;
struct member *q;
for (i = 0; i < t->size; i++)
for (q = t->buckets[i]; q; q = q->link)
if (!Set_member(s, q->member))
{
struct member *p;
const void *member = q->member;
int i = (*set->hash)(member)%set->size;
NEW(p);
p->member = member;
p->link = set->buckets[i];
set->buckets[i] = p;
set->length++;
}
}
{ T u = t; t = s; s = u; }
{ int i;
struct member *q;
for (i = 0; i < t->size; i++)
for (q = t->buckets[i]; q; q = q->link)
if (!Set_member(s, q->member))
{
struct member *p;
const void *member = q->member;
int i = (*set->hash)(member)%set->size;
NEW(p);
p->member = member;
p->link = set->buckets[i];
set->buckets[i] = p;
set->length++;
}
}
return set;
}
}
eisl-5.55/cii/src/stack.c 0000664 0000000 0000000 00000001476 15066676224 0015236 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include "assert.h"
#include "mem.h"
#include "stack.h"
#define T Stack_T
struct T {
int count;
struct elem {
void *x;
struct elem *link;
} *head;
};
T Stack_new(void) {
T stk;
NEW(stk);
stk->count = 0;
stk->head = NULL;
return stk;
}
int Stack_empty(T stk) {
assert(stk);
return stk->count == 0;
}
void Stack_push(T stk, void *x) {
struct elem *t;
assert(stk);
NEW(t);
t->x = x;
t->link = stk->head;
stk->head = t;
stk->count++;
}
void *Stack_pop(T stk) {
void *x;
struct elem *t;
assert(stk);
assert(stk->count > 0);
t = stk->head;
stk->head = t->link;
stk->count--;
x = t->x;
FREE(t);
return x;
}
void Stack_free(T *stk) {
struct elem *t, *u;
assert(stk && *stk);
for (t = (*stk)->head; t; t = u) {
u = t->link;
FREE(t);
}
FREE(*stk);
}
eisl-5.55/cii/src/str.c 0000664 0000000 0000000 00000013404 15066676224 0014733 0 ustar 00root root 0000000 0000000 //static char rcsid[] = "$Id$";
#include
#include
#include "assert.h"
#include "fmt.h"
#include "str.h"
#include "mem.h"
#define idx(i, len) ((i) <= 0 ? (i) + (len) : (i) - 1)
#define convert(s, i, j) do { int len; \
assert(s); len = strlen(s); \
i = idx(i, len); j = idx(j, len); \
if (i > j) { int t = i; i = j; j = t; } \
assert(i >= 0 && j <= len); } while (0)
char *Str_sub(const char *s, int i, int j) {
char *str, *p;
convert(s, i, j);
p = str = ALLOC(j - i + 1);
while (i < j)
*p++ = s[i++];
*p = '\0';
return str;
}
char *Str_dup(const char *s, int i, int j, int n) {
int k;
char *str, *p;
assert(n >= 0);
convert(s, i, j);
p = str = ALLOC(n*(j - i) + 1);
if (j - i > 0)
while (n-- > 0)
for (k = i; k < j; k++)
*p++ = s[k];
*p = '\0';
return str;
}
char *Str_reverse(const char *s, int i, int j) {
char *str, *p;
convert(s, i, j);
p = str = ALLOC(j - i + 1);
while (j > i)
*p++ = s[--j];
*p = '\0';
return str;
}
char *Str_cat(const char *s1, int i1, int j1,
const char *s2, int i2, int j2) {
char *str, *p;
convert(s1, i1, j1);
convert(s2, i2, j2);
p = str = ALLOC(j1 - i1 + j2 - i2 + 1);
while (i1 < j1)
*p++ = s1[i1++];
while (i2 < j2)
*p++ = s2[i2++];
*p = '\0';
return str;
}
char *Str_catv(const char *s, ...) {
char *str, *p;
const char *save = s;
int i, j, len = 0;
va_list ap;
va_start(ap, s);
while (s) {
i = va_arg(ap, int);
j = va_arg(ap, int);
convert(s, i, j);
len += j - i;
s = va_arg(ap, const char *);
}
va_end(ap);
p = str = ALLOC(len + 1);
s = save;
va_start(ap, s);
while (s) {
i = va_arg(ap, int);
j = va_arg(ap, int);
convert(s, i, j);
while (i < j)
*p++ = s[i++];
s = va_arg(ap, const char *);
}
va_end(ap);
*p = '\0';
return str;
}
char *Str_map(const char *s, int i, int j,
const char *from, const char *to) {
static char map[256] = { 0 };
if (from && to) {
unsigned c;
for (c = 0; c < sizeof map; c++)
map[c] = c;
while (*from && *to)
map[(unsigned char)*from++] = *to++;
assert(*from == 0 && *to == 0);
} else {
assert(from == NULL && to == NULL && s);
assert(map['a']);
}
if (s) {
char *str, *p;
convert(s, i, j);
p = str = ALLOC(j - i + 1);
while (i < j)
*p++ = map[(unsigned char)s[i++]];
*p = '\0';
return str;
} else
return NULL;
}
int Str_pos(const char *s, int i) {
int len;
assert(s);
len = strlen(s);
i = idx(i, len);
assert(i >= 0 && i <= len);
return i + 1;
}
int Str_len(const char *s, int i, int j) {
convert(s, i, j);
return j - i;
}
int Str_cmp(const char *s1, int i1, int j1,
const char *s2, int i2, int j2) {
convert(s1, i1, j1);
convert(s2, i2, j2);
s1 += i1;
s2 += i2;
if (j1 - i1 < j2 - i2) {
int cond = strncmp(s1, s2, j1 - i1);
return cond == 0 ? -1 : cond;
} else if (j1 - i1 > j2 - i2) {
int cond = strncmp(s1, s2, j2 - i2);
return cond == 0 ? +1 : cond;
} else
return strncmp(s1, s2, j1 - i1);
}
int Str_chr(const char *s, int i, int j, int c) {
convert(s, i, j);
for ( ; i < j; i++)
if (s[i] == c)
return i + 1;
return 0;
}
int Str_rchr(const char *s, int i, int j, int c) {
convert(s, i, j);
while (j > i)
if (s[--j] == c)
return j + 1;
return 0;
}
int Str_upto(const char *s, int i, int j,
const char *set) {
assert(set);
convert(s, i, j);
for ( ; i < j; i++)
if (strchr(set, s[i]))
return i + 1;
return 0;
}
int Str_rupto(const char *s, int i, int j,
const char *set) {
assert(set);
convert(s, i, j);
while (j > i)
if (strchr(set, s[--j]))
return j + 1;
return 0;
}
int Str_find(const char *s, int i, int j,
const char *str) {
int len;
convert(s, i, j);
assert(str);
len = strlen(str);
if (len == 0)
return i + 1;
else if (len == 1) {
for ( ; i < j; i++)
if (s[i] == *str)
return i + 1;
} else
for ( ; i + len <= j; i++)
if ((strncmp(&s[i], str, len) == 0))
return i + 1;
return 0;
}
int Str_rfind(const char *s, int i, int j,
const char *str) {
int len;
convert(s, i, j);
assert(str);
len = strlen(str);
if (len == 0)
return j + 1;
else if (len == 1) {
while (j > i)
if (s[--j] == *str)
return j + 1;
} else
for ( ; j - len >= i; j--)
if (strncmp(&s[j-len], str, len) == 0)
return j - len + 1;
return 0;
}
int Str_any(const char *s, int i, const char *set) {
int len;
assert(s);
assert(set);
len = strlen(s);
i = idx(i, len);
assert(i >= 0 && i <= len);
if (i < len && strchr(set, s[i]))
return i + 2;
return 0;
}
int Str_many(const char *s, int i, int j,
const char *set) {
assert(set);
convert(s, i, j);
if (i < j && strchr(set, s[i])) {
do
i++;
while (i < j && strchr(set, s[i]));
return i + 1;
}
return 0;
}
int Str_rmany(const char *s, int i, int j,
const char *set) {
assert(set);
convert(s, i, j);
if (j > i && strchr(set, s[j-1])) {
do
--j;
while (j >= i && strchr(set, s[j]));
return j + 2;
}
return 0;
}
int Str_match(const char *s, int i, int j,
const char *str) {
int len;
convert(s, i, j);
assert(str);
len = strlen(str);
if (len == 0)
return i + 1;
else if (len == 1) {
if (i < j && s[i] == *str)
return i + 2;
} else if (i + len <= j && (strncmp(&s[i], str, len) == 0))
return i + len + 1;
return 0;
}
int Str_rmatch(const char *s, int i, int j,
const char *str) {
int len;
convert(s, i, j);
assert(str);
len = strlen(str);
if (len == 0)
return j + 1;
else if (len == 1) {
if (j > i && s[j-1] == *str)
return j;
} else if (j - len >= i
&& strncmp(&s[j-len], str, len) == 0)
return j - len + 1;
return 0;
}
void Str_fmt(int code , va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
char *s;
int i, j;
assert(box && flags);
s = va_arg(box->ap, char *);
i = va_arg(box->ap, int);
j = va_arg(box->ap, int);
convert(s, i, j);
Fmt_puts(s + i, j - i, put, cl, flags,
width, precision);
}
eisl-5.55/cii/src/strerror.c 0000664 0000000 0000000 00000000642 15066676224 0016005 0 ustar 00root root 0000000 0000000 #include
#include
/*lint -e613
strerror is defined here because some vendors don't provide it.
*/
char *strerror(int errnum) {
extern int sys_nerr;
extern char *sys_errlist[];
static char null[1] = { 0 };
if (errnum <= 0)
return null;
else if (errnum >= sys_nerr) {
static char errmsg[50];
sprintf(errmsg, "error %d", errnum);
return errmsg;
} else
return sys_errlist[errnum];
}
eisl-5.55/cii/src/strncmp.c 0000664 0000000 0000000 00000000572 15066676224 0015613 0 ustar 00root root 0000000 0000000 #include
/*lint -e613
strncmp is defined here because some vendors don't implement
it, strcmp, or memcmp correctly; they must treat the bytes
as unsigned chars.
*/
int strncmp(const char *s1, const char *s2, size_t n) {
for ( ; n-- > 0; s1++, s2++)
if (*s1 != *s2)
return (unsigned char)*s1 - (unsigned char)*s2;
else if (*s1 == 0)
return 0;
return 0;
}
eisl-5.55/cii/src/swtch.s 0000664 0000000 0000000 00000007111 15066676224 0015271 0 ustar 00root root 0000000 0000000 #if alpha
.globl _swtch
.ent _swtch
_swtch: lda $sp,-112($sp) # allocate _swtch's frame
.frame $sp,112,$26
.fmask 0x3f0000,-112
stt $f21,0($sp) # save from's registers
stt $f20,8($sp)
stt $f19,16($sp)
stt $f18,24($sp)
stt $f17,32($sp)
stt $f16,40($sp)
.mask 0x400fe00,-64
stq $26,48+0($sp)
stq $15,48+8($sp)
stq $14,48+16($sp)
stq $13,48+24($sp)
stq $12,48+32($sp)
stq $11,48+40($sp)
stq $10,48+48($sp)
stq $9,48+56($sp)
.prologue 0
stq $sp,0($16) # save from's stack pointer
ldq $sp,0($17) # restore to's stack pointer
ldt $f21,0($sp) # restore to's registers
ldt $f20,8($sp)
ldt $f19,16($sp)
ldt $f18,24($sp)
ldt $f17,32($sp)
ldt $f16,40($sp)
ldq $26,48+0($sp)
ldq $15,48+8($sp)
ldq $14,48+16($sp)
ldq $13,48+24($sp)
ldq $12,48+32($sp)
ldq $11,48+40($sp)
ldq $10,48+48($sp)
ldq $9,48+56($sp)
lda $sp,112($sp) # deallocate frame
ret $31,($26)
.end _swtch
.globl _start
.ent _start
_start: .frame $sp,0,$26
.mask 0x0,0
.prologue 0
mov $14,$16 # register 14 holds args
mov $15,$27 # register 15 holds apply
jsr $26,($27) # call apply
ldgp $26,0($26) # reload the global pointer
mov $0,$16 # Thread_exit(apply(args))
mov $13,$27 # register 13 has Thread_exit
jsr $26,($27)
call_pal 0
.end _start
.globl _ENDMONITOR
_ENDMONITOR:
#elif sparc
.global __swtch
.align 4
.proc 4
__swtch: save %sp,-(8+64),%sp
st %fp,[%sp+64+0] ! save from's frame pointer
st %i7,[%sp+64+4] ! save from's return address
ta 3 ! flush from's registers
st %sp,[%i0] ! save from's stack pointer
ld [%i1],%sp ! load to's stack pointer
ld [%sp+64+0],%fp ! restore to's frame pointer
ld [%sp+64+4],%i7 ! restore to's return address
ret ! continue execution of to
restore
.global __start
.align 4
.proc 4
__start: ld [%sp+64+4],%o0
ld [%sp+64],%o1
call %o1; nop
call _Thread_exit; nop
unimp 0
.global __ENDMONITOR
__ENDMONITOR:
#elif mips
.text
.globl _swtch
.align 2
.ent _swtch
.set reorder
_swtch: .frame $sp,88,$31
subu $sp,88
.fmask 0xfff00000,-48
s.d $f20,0($sp)
s.d $f22,8($sp)
s.d $f24,16($sp)
s.d $f26,24($sp)
s.d $f28,32($sp)
s.d $f30,40($sp)
.mask 0xc0ff0000,-4
sw $16,48+0($sp)
sw $17,48+4($sp)
sw $18,48+8($sp)
sw $19,48+12($sp)
sw $20,48+16($sp)
sw $21,48+20($sp)
sw $22,48+24($sp)
sw $23,48+28($sp)
sw $30,48+32($sp)
sw $31,48+36($sp)
sw $sp,0($4)
lw $sp,0($5)
l.d $f20,0($sp)
l.d $f22,8($sp)
l.d $f24,16($sp)
l.d $f26,24($sp)
l.d $f28,32($sp)
l.d $f30,40($sp)
lw $16,48+0($sp)
lw $17,48+4($sp)
lw $18,48+8($sp)
lw $19,48+12($sp)
lw $20,48+16($sp)
lw $21,48+20($sp)
lw $22,48+24($sp)
lw $23,48+28($sp)
lw $30,48+32($sp)
lw $31,48+36($sp)
addu $sp,88
j $31
.globl _start
_start: move $4,$23 # register 23 holds args
move $25,$30 # register 30 holds apply
jal $25
move $4,$2 # Thread_exit(apply(p))
move $25,$21 # register 21 holds Thread_exit
jal $25
syscall
.end _swtch
.globl _ENDMONITOR
_ENDMONITOR:
#elif (linux || __APPLE__) && i386
.align 4
#if __APPLE__
.globl __swtch
__swtch:
#else
.globl _swtch
_swtch:
#endif
subl $16,%esp
movl %ebx,0(%esp)
movl %esi,4(%esp)
movl %edi,8(%esp)
movl %ebp,12(%esp)
movl 20(%esp),%eax
movl %esp,0(%eax)
movl 24(%esp),%eax
movl 0(%eax),%esp
movl 0(%esp),%ebx
movl 4(%esp),%esi
movl 8(%esp),%edi
movl 12(%esp),%ebp
addl $16,%esp
ret
.align 4
.globl __thrstart
.globl _thrstart
__thrstart:
_thrstart:
pushl %edi # stack is 16-byte aligned after this push
call *%esi
subl $12,%esp # ensure stack is 16-byte aligned before the call
pushl %eax
#if __APPLE__
call _Thread_exit
#else
call Thread_exit
#endif
.globl __ENDMONITOR
.globl _ENDMONITOR
__ENDMONITOR:
_ENDMONITOR:
#else
Unsupported platform
#endif
eisl-5.55/cii/src/table.c 0000664 0000000 0000000 00000006362 15066676224 0015217 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include
#include "mem.h"
#include "assert.h"
#include "table.h"
#define T Table_T
struct T {
int size;
int (*cmp)(const void *x, const void *y);
unsigned (*hash)(const void *key);
int length;
unsigned timestamp;
struct binding {
struct binding *link;
const void *key;
void *value;
} **buckets;
};
static int cmpatom(const void *x, const void *y) {
return x != y;
}
static unsigned hashatom(const void *key) {
return (unsigned long)key>>2;
}
T Table_new(int hint,
int cmp(const void *x, const void *y),
unsigned hash(const void *key)) {
T table;
int i;
static int primes[] = { 509, 509, 1021, 2053, 4093,
8191, 16381, 32771, 65521, INT_MAX };
assert(hint >= 0);
for (i = 1; primes[i] < hint; i++)
;
table = ALLOC(sizeof (*table) +
primes[i-1]*sizeof (table->buckets[0]));
table->size = primes[i-1];
table->cmp = cmp ? cmp : cmpatom;
table->hash = hash ? hash : hashatom;
table->buckets = (struct binding **)(table + 1);
for (i = 0; i < table->size; i++)
table->buckets[i] = NULL;
table->length = 0;
table->timestamp = 0;
return table;
}
void *Table_get(T table, const void *key) {
int i;
struct binding *p;
assert(table);
assert(key);
i = (*table->hash)(key)%table->size;
for (p = table->buckets[i]; p; p = p->link)
if ((*table->cmp)(key, p->key) == 0)
break;
return p ? p->value : NULL;
}
void *Table_put(T table, const void *key, void *value) {
int i;
struct binding *p;
void *prev;
assert(table);
assert(key);
i = (*table->hash)(key)%table->size;
for (p = table->buckets[i]; p; p = p->link)
if ((*table->cmp)(key, p->key) == 0)
break;
if (p == NULL) {
NEW(p);
p->key = key;
p->link = table->buckets[i];
table->buckets[i] = p;
table->length++;
prev = NULL;
} else
prev = p->value;
p->value = value;
table->timestamp++;
return prev;
}
int Table_length(T table) {
assert(table);
return table->length;
}
void Table_map(T table,
void apply(const void *key, void **value, void *cl),
void *cl) {
int i;
unsigned stamp;
struct binding *p;
assert(table);
assert(apply);
stamp = table->timestamp;
for (i = 0; i < table->size; i++)
for (p = table->buckets[i]; p; p = p->link) {
apply(p->key, &p->value, cl);
assert(table->timestamp == stamp);
}
}
void *Table_remove(T table, const void *key) {
int i;
struct binding **pp;
assert(table);
assert(key);
table->timestamp++;
i = (*table->hash)(key)%table->size;
for (pp = &table->buckets[i]; *pp; pp = &(*pp)->link)
if ((*table->cmp)(key, (*pp)->key) == 0) {
struct binding *p = *pp;
void *value = p->value;
*pp = p->link;
FREE(p);
table->length--;
return value;
}
return NULL;
}
void **Table_toArray(T table, void *end) {
int i, j = 0;
void **array;
struct binding *p;
assert(table);
array = ALLOC((2*table->length + 1)*sizeof (*array));
for (i = 0; i < table->size; i++)
for (p = table->buckets[i]; p; p = p->link) {
array[j++] = (void *)p->key;
array[j++] = p->value;
}
array[j] = end;
return array;
}
void Table_free(T *table) {
assert(table && *table);
if ((*table)->length > 0) {
int i;
struct binding *p, *q;
for (i = 0; i < (*table)->size; i++)
for (p = (*table)->buckets[i]; p; p = q) {
q = p->link;
FREE(p);
}
}
FREE(*table);
}
eisl-5.55/cii/src/text.c 0000664 0000000 0000000 00000023351 15066676224 0015111 0 ustar 00root root 0000000 0000000 //static const char *rcsid = "$Id$";
#include
#include
#include "assert.h"
#include "fmt.h"
#include "text.h"
#include "mem.h"
#define T Text_T
#define idx(i, len) ((i) <= 0 ? (i) + (len) : (i) - 1)
#define isatend(s, n) ((s).str+(s).len == current->avail\
&& current->avail + (n) <= current->limit)
#define equal(s, i, t) \
(memcmp(&(s).str[i], (t).str, (t).len) == 0)
struct Text_save_T {
struct chunk *current;
char *avail;
};
static char cset[] =
"\000\001\002\003\004\005\006\007\010\011\012\013\014\015\016\017"
"\020\021\022\023\024\025\026\027\030\031\032\033\034\035\036\037"
"\040\041\042\043\044\045\046\047\050\051\052\053\054\055\056\057"
"\060\061\062\063\064\065\066\067\070\071\072\073\074\075\076\077"
"\100\101\102\103\104\105\106\107\110\111\112\113\114\115\116\117"
"\120\121\122\123\124\125\126\127\130\131\132\133\134\135\136\137"
"\140\141\142\143\144\145\146\147\150\151\152\153\154\155\156\157"
"\160\161\162\163\164\165\166\167\170\171\172\173\174\175\176\177"
"\200\201\202\203\204\205\206\207\210\211\212\213\214\215\216\217"
"\220\221\222\223\224\225\226\227\230\231\232\233\234\235\236\237"
"\240\241\242\243\244\245\246\247\250\251\252\253\254\255\256\257"
"\260\261\262\263\264\265\266\267\270\271\272\273\274\275\276\277"
"\300\301\302\303\304\305\306\307\310\311\312\313\314\315\316\317"
"\320\321\322\323\324\325\326\327\330\331\332\333\334\335\336\337"
"\340\341\342\343\344\345\346\347\350\351\352\353\354\355\356\357"
"\360\361\362\363\364\365\366\367\370\371\372\373\374\375\376\377"
;
const T Text_cset = { 256, cset };
const T Text_ascii = { 127, cset };
const T Text_ucase = { 26, &cset['A'] };
const T Text_lcase = { 26, &cset['a'] };
const T Text_digits = { 10, &cset['0'] };
const T Text_null = { 0, cset };
static struct chunk {
struct chunk *link;
char *avail;
char *limit;
} head = { NULL, NULL, NULL }, *current = &head;
static char *alloc(int len) {
assert(len >= 0);
if (current->avail == NULL || current->avail + len > current->limit) {
current = current->link =
ALLOC(sizeof (*current) + 10*1024 + len);
current->avail = (char *)(current + 1);
current->limit = current->avail + 10*1024 + len;
current->link = NULL;
}
current->avail += len;
return current->avail - len;
}
int Text_pos(T s, int i) {
assert(s.len >= 0 && s.str);
i = idx(i, s.len);
assert(i >= 0 && i <= s.len);
return i + 1;
}
T Text_box(const char *str, int len) {
T text;
assert(str);
assert(len >= 0);
text.str = str;
text.len = len;
return text;
}
T Text_sub(T s, int i, int j) {
T text;
assert(s.len >= 0 && s.str);
i = idx(i, s.len);
j = idx(j, s.len);
if (i > j) { int t = i; i = j; j = t; }
assert(i >= 0 && j <= s.len);
text.len = j - i;
text.str = s.str + i;
return text;
}
T Text_put(const char *str) {
T text;
assert(str);
text.len = strlen(str);
text.str = memcpy(alloc(text.len), str, text.len);
return text;
}
char *Text_get(char *str, int size , T s) {
assert(s.len >= 0 && s.str);
if (str == NULL)
str = ALLOC(s.len + 1);
else
assert(size >= s.len + 1);
memcpy(str, s.str, s.len);
str[s.len] = '\0';
return str;
}
T Text_dup(T s, int n) {
assert(s.len >= 0 && s.str);
assert(n >= 0);
if (n == 0 || s.len == 0)
return Text_null;
if (n == 1)
return s;
{
T text;
char *p;
text.len = n*s.len;
if (isatend(s, text.len - s.len)) {
text.str = s.str;
p = alloc(text.len - s.len);
n--;
} else
text.str = p = alloc(text.len);
for ( ; n-- > 0; p += s.len)
memcpy(p, s.str, s.len);
return text;
}
}
T Text_cat(T s1, T s2) {
assert(s1.len >= 0 && s1.str);
assert(s2.len >= 0 && s2.str);
if (s1.len == 0)
return s2;
if (s2.len == 0)
return s1;
if (s1.str + s1.len == s2.str) {
s1.len += s2.len;
return s1;
}
{
T text;
text.len = s1.len + s2.len;
if (isatend(s1, s2.len)) {
text.str = s1.str;
memcpy(alloc(s2.len), s2.str, s2.len);
} else {
char *p;
text.str = p = alloc(s1.len + s2.len);
memcpy(p, s1.str, s1.len);
memcpy(p + s1.len, s2.str, s2.len);
}
return text;
}
}
T Text_reverse(T s) {
assert(s.len >= 0 && s.str);
if (s.len == 0)
return Text_null;
else if (s.len == 1)
return s;
else {
T text;
char *p;
int i = s.len;
text.len = s.len;
text.str = p = alloc(s.len);
while (--i >= 0)
*p++ = s.str[i];
return text;
}
}
T Text_map(T s, const T *from, const T *to) {
static char map[256];
//static int inited = 0;
assert(s.len >= 0 && s.str);
if (from && to) {
int k;
for (k = 0; k < (int)sizeof map; k++)
map[k] = k;
assert(from->len == to->len);
for (k = 0; k < from->len; k++)
map[(unsigned char)from->str[k]] = to->str[k];
//inited = 1;
} else {
assert(from == NULL && to == NULL);
assert(inited);
}
if (s.len == 0)
return Text_null;
else {
T text;
int i;
char *p;
text.len = s.len;
text.str = p = alloc(s.len);
for (i = 0; i < s.len; i++)
*p++ = map[(unsigned char)s.str[i]];
return text;
}
}
int Text_cmp(T s1, T s2) {
assert(s1.len >= 0 && s1.str);
assert(s2.len >= 0 && s2.str);
if (s1.str == s2.str)
return s1.len - s2.len;
else if (s1.len < s2.len) {
int cond = memcmp(s1.str, s2.str, s1.len);
return cond == 0 ? -1 : cond;
} else if (s1.len > s2.len) {
int cond = memcmp(s1.str, s2.str, s2.len);
return cond == 0 ? +1 : cond;
} else
return memcmp(s1.str, s2.str, s1.len);
}
Text_save_T Text_save(void) {
Text_save_T save;
NEW(save);
save->current = current;
save->avail = current->avail;
alloc(1);
return save;
}
void Text_restore(Text_save_T *save) {
struct chunk *p, *q;
assert(save && *save);
current = (*save)->current;
current->avail = (*save)->avail;
FREE(*save);
for (p = current->link; p; p = q) {
q = p->link;
FREE(p);
}
current->link = NULL;
}
int Text_chr(T s, int i, int j, int c) {
assert(s.len >= 0 && s.str);
i = idx(i, s.len);
j = idx(j, s.len);
if (i > j) { int t = i; i = j; j = t; }
assert(i >= 0 && j <= s.len);
for ( ; i < j; i++)
if (s.str[i] == c)
return i + 1;
return 0;
}
int Text_rchr(T s, int i, int j, int c) {
assert(s.len >= 0 && s.str);
i = idx(i, s.len);
j = idx(j, s.len);
if (i > j) { int t = i; i = j; j = t; }
assert(i >= 0 && j <= s.len);
while (j > i)
if (s.str[--j] == c)
return j + 1;
return 0;
}
int Text_upto(T s, int i, int j, T set) {
assert(set.len >= 0 && set.str);
assert(s.len >= 0 && s.str);
i = idx(i, s.len);
j = idx(j, s.len);
if (i > j) { int t = i; i = j; j = t; }
assert(i >= 0 && j <= s.len);
for ( ; i < j; i++)
if (memchr(set.str, s.str[i], set.len))
return i + 1;
return 0;
}
int Text_rupto(T s, int i, int j, T set) {
assert(set.len >= 0 && set.str);
assert(s.len >= 0 && s.str);
i = idx(i, s.len);
j = idx(j, s.len);
if (i > j) { int t = i; i = j; j = t; }
assert(i >= 0 && j <= s.len);
while (j > i)
if (memchr(set.str, s.str[--j], set.len))
return j + 1;
return 0;
}
int Text_find(T s, int i, int j, T str) {
assert(str.len >= 0 && str.str);
assert(s.len >= 0 && s.str);
i = idx(i, s.len);
j = idx(j, s.len);
if (i > j) { int t = i; i = j; j = t; }
assert(i >= 0 && j <= s.len);
if (str.len == 0)
return i + 1;
else if (str.len == 1) {
for ( ; i < j; i++)
if (s.str[i] == *str.str)
return i + 1;
} else
for ( ; i + str.len <= j; i++)
if (equal(s, i, str))
return i + 1;
return 0;
}
int Text_rfind(T s, int i, int j, T str) {
assert(str.len >= 0 && str.str);
assert(s.len >= 0 && s.str);
i = idx(i, s.len);
j = idx(j, s.len);
if (i > j) { int t = i; i = j; j = t; }
assert(i >= 0 && j <= s.len);
if (str.len == 0)
return j + 1;
else if (str.len == 1) {
while (j > i)
if (s.str[--j] == *str.str)
return j + 1;
} else
for ( ; j - str.len >= i; j--)
if (equal(s, j - str.len, str))
return j - str.len + 1;
return 0;
}
int Text_any(T s, int i, T set) {
assert(s.len >= 0 && s.str);
assert(set.len >= 0 && set.str);
i = idx(i, s.len);
assert(i >= 0 && i <= s.len);
if (i < s.len && memchr(set.str, s.str[i], set.len))
return i + 2;
return 0;
}
int Text_many(T s, int i, int j, T set) {
assert(set.len >= 0 && set.str);
assert(s.len >= 0 && s.str);
i = idx(i, s.len);
j = idx(j, s.len);
if (i > j) { int t = i; i = j; j = t; }
assert(i >= 0 && j <= s.len);
if (i < j && memchr(set.str, s.str[i], set.len)) {
do
i++;
while (i < j
&& memchr(set.str, s.str[i], set.len));
return i + 1;
}
return 0;
}
int Text_rmany(T s, int i, int j, T set) {
assert(set.len >= 0 && set.str);
assert(s.len >= 0 && s.str);
i = idx(i, s.len);
j = idx(j, s.len);
if (i > j) { int t = i; i = j; j = t; }
assert(i >= 0 && j <= s.len);
if (j > i && memchr(set.str, s.str[j-1], set.len)) {
do
--j;
while (j >= i
&& memchr(set.str, s.str[j], set.len));
return j + 2;
}
return 0;
}
int Text_match(T s, int i, int j, T str) {
assert(str.len >= 0 && str.str);
assert(s.len >= 0 && s.str);
i = idx(i, s.len);
j = idx(j, s.len);
if (i > j) { int t = i; i = j; j = t; }
assert(i >= 0 && j <= s.len);
if (str.len == 0)
return i + 1;
else if (str.len == 1) {
if (i < j && s.str[i] == *str.str)
return i + 2;
} else if (i + str.len <= j && equal(s, i, str))
return i + str.len + 1;
return 0;
}
int Text_rmatch(T s, int i, int j, T str) {
assert(str.len >= 0 && str.str);
assert(s.len >= 0 && s.str);
i = idx(i, s.len);
j = idx(j, s.len);
if (i > j) { int t = i; i = j; j = t; }
assert(i >= 0 && j <= s.len);
if (str.len == 0)
return j + 1;
else if (str.len == 1) {
if (j > i && s.str[j-1] == *str.str)
return j;
} else if (j - str.len >= i
&& equal(s, j - str.len, str))
return j - str.len + 1;
return 0;
}
void Text_fmt(int code , va_list_box *box,
int put(int c, void *cl), void *cl,
unsigned char flags[], int width, int precision) {
T *s;
assert(box && flags);
s = va_arg(box->ap, T*);
assert(s && s->len >= 0 && s->str);
Fmt_puts(s->str, s->len, put, cl, flags,
width, precision);
}
eisl-5.55/cii/src/thread-nt.c 0000664 0000000 0000000 00000014617 15066676224 0016020 0 ustar 00root root 0000000 0000000 #include
#include
#include
#include
#include
#include
#include "assert.h"
#include "mem.h"
#include "thread.h"
#include "sem.h"
static char rcsid[] = "$Id$";
#define T Thread_T
struct T {
DWORD IDThread; /* Win 32 thread identifier */
T handle; /* self pointer */
int code; /* exit code */
HANDLE join; /* join semaphore */
T joinlist; /* threads waiting on join */
T link; /* next thread on this join list */
T next; /* next thread on this hash chain */
int alerted; /* 1 if this thread has been alerted */
int (*apply)(void *); /* initial function for this thread */
void *args; /* argument for apply */
};
const Except_T Thread_Alerted = { "Thread alerted" };
const Except_T Thread_Failed = { "Thread creation failed" };
static T allthreads[317];
#define HASH(id) ((int)((id)%(sizeof allthreads/sizeof allthreads[0])))
static int nthreads; /* number of threads in allthreads */
static T root;
static HANDLE join0; /* Thread_join(NULL) semaphore */
static int join0count; /* number of threads waiting on join0; always 0 or 1 */
static int critical;
static CRITICAL_SECTION csection;
#define ENTERCRITICAL EnterCriticalSection(&csection); assert(critical == 0); critical++
#define LEAVECRITICAL critical--; assert(critical == 0); LeaveCriticalSection(&csection)
static T getThreadByID(DWORD id) {
T t;
ENTERCRITICAL;
for (t = allthreads[HASH(id)]; t != NULL; t = t->next)
if (t->IDThread == id)
break;
LEAVECRITICAL;
assert(t);
return t;
}
/* removeThread - must be called from within a critical region */
static void removeThread(T t) {
T *q;
q = &allthreads[HASH(t->IDThread)];
for ( ; *q != NULL && *q != t; q = &(*q)->next)
;
assert(*q == t);
*q = t->next;
nthreads--;
t->handle = NULL;
}
static void addThread(T t) {
T *q;
ENTERCRITICAL;
q = &allthreads[HASH(t->IDThread)];
t->next = *q;
*q = t;
nthreads++;
t->handle = t;
LEAVECRITICAL;
}
static void testalert(T t) {
ENTERCRITICAL;
if (t->alerted) {
t->alerted = 0;
LEAVECRITICAL;
RAISE(Thread_Alerted);
}
LEAVECRITICAL;
}
int Thread_init(int preempt, ...) {
assert(preempt == 0 || preempt == 1);
assert(root == NULL);
TRY
NEW0(root);
EXCEPT(Mem_Failed)
return -1;
END_TRY;
join0 = CreateSemaphore(NULL, 0, 1, NULL);
if (join0 == NULL)
return -1;
root->join = CreateSemaphore(NULL, 0, INT_MAX, NULL);
if (root->join == NULL) {
BOOL result = CloseHandle(join0);
assert(result == TRUE);
return -1;
}
InitializeCriticalSection(&csection);
root->IDThread = GetCurrentThreadId();
addThread(root);
/* handle preempt == 0 */
return 1;
}
T Thread_self(void) {
assert(root);
return getThreadByID(GetCurrentThreadId());
}
void Thread_pause(void) {
assert(root);
Sleep(0);
}
int Thread_join(T t) {
T current = Thread_self();
assert(root);
assert(t != current);
testalert(current);
if (t != NULL) {
ENTERCRITICAL;
if (t->handle == t) {
HANDLE join = t->join;
DWORD result;
assert(current->link == NULL);
current->link = t->joinlist;
t->joinlist = current;
LEAVECRITICAL;
result = WaitForSingleObject(join, INFINITE);
assert(result != WAIT_FAILED);
testalert(current);
return current->code;
} else {
LEAVECRITICAL;
return -1;
}
}
ENTERCRITICAL;
if (nthreads > 1) {
DWORD result;
assert(join0count == 0);
join0count++;
LEAVECRITICAL;
result = WaitForSingleObject(join0, INFINITE);
assert(result != WAIT_FAILED);
ENTERCRITICAL;
join0count--;
LEAVECRITICAL;
testalert(current);
} else {
assert(join0count == 0);
LEAVECRITICAL;
return 0;
}
}
void Thread_exit(int code) {
BOOL result;
T current = Thread_self();
ENTERCRITICAL;
removeThread(current);
if (current->joinlist != NULL) {
T t, n;
int count = 0;
assert(current->join);
for (t = current->joinlist; t != NULL; t = n) {
t->code = code;
n = t->link;
t->link = NULL;
count++;
}
current->joinlist = NULL;
result = ReleaseSemaphore(current->join, count, NULL);
assert(result == TRUE);
}
result = CloseHandle(current->join);
assert(result == TRUE);
current->join = NULL;
if (join0count > 0 && nthreads == 1) {
assert(join0count == 1);
result = ReleaseSemaphore(join0, 1, NULL);
assert(result == TRUE);
}
if (nthreads == 0) {
result = CloseHandle(join0);
assert(result == TRUE);
}
FREE(current);
LEAVECRITICAL;
_endthreadex(code);
}
void Thread_alert(T t) {
assert(root);
ENTERCRITICAL;
assert(t && t->handle == t);
t->alerted = 1;
LEAVECRITICAL;
}
static unsigned __stdcall start(void *p) {
T t = p;
if (Except_index == -1)
Except_init();
TlsSetValue(Except_index, NULL);
Thread_exit((*t->apply)(t->args));
return 0;
}
T Thread_new(int apply(void *), void *args, int nbytes, ...) {
T t;
HANDLE hThread;
assert(root);
assert(apply);
assert(args && nbytes >= 0 || args == NULL);
if (args == NULL)
nbytes = 0;
TRY
t = ALLOC((sizeof (*t) + nbytes + 15)&~15);
memset(t, '\0', sizeof *t);
EXCEPT(Mem_Failed)
RAISE(Thread_Failed);
END_TRY;
t->join = CreateSemaphore(NULL, 0, INT_MAX, NULL);
if (t->join == NULL) {
FREE(t);
RAISE(Thread_Failed);
}
if (nbytes > 0) {
t->args = t + 1;
memcpy(t->args, args, nbytes);
} else
t->args = args;
t->apply = apply;
hThread = (HANDLE)_beginthreadex(
NULL, /* default security attributes */
0, /* default stack size */
start, /* initial function */
t, /* start's argument */
0, /* default thread creation flags */
&t->IDThread /* where to store the thread id */
);
if (hThread == NULL) {
CloseHandle(t->join);
FREE(t);
RAISE(Thread_Failed);
}
CloseHandle(hThread);
addThread(t);
return t;
}
#undef T
#define T Sem_T
T *Sem_new(int count) {
T *s;
NEW(s);
Sem_init(s, count);
return s;
}
void Sem_init(T *s, int count) {
assert(root);
assert(s);
assert(count >= 0);
s->count = 0;
s->queue = CreateSemaphore(NULL, count, INT_MAX, NULL);
assert(s->queue);
}
void Sem_wait(T *s) {
DWORD result;
Thread_T current = Thread_self();
assert(s);
testalert(current);
result = WaitForSingleObject(s->queue, INFINITE);
assert(result != WAIT_FAILED);
ENTERCRITICAL;
if (current->alerted) {
BOOL result;
current->alerted = 0;
LEAVECRITICAL;
result = ReleaseSemaphore(s->queue, 1, NULL);
assert(result == TRUE);
RAISE(Thread_Alerted);
}
LEAVECRITICAL;
}
void Sem_signal(T *s) {
BOOL result;
assert(root);
assert(s);
result = ReleaseSemaphore(s->queue, 1, NULL);
assert(result == TRUE);
}
#undef T
eisl-5.55/cii/src/thread.c 0000664 0000000 0000000 00000014763 15066676224 0015403 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include
#include
#include
#include
#include "assert.h"
#include "mem.h"
#include "thread.h"
#include "sem.h"
void _MONITOR(void) {}
extern void _ENDMONITOR(void);
#define T Thread_T
#define isempty(q) ((q) == NULL)
struct T {
unsigned long *sp; /* must be first */
T link;
T *inqueue;
T handle;
Except_Frame *estack;
int code;
T join;
T next;
int alerted;
};
static T ready = NULL;
static T current;
static int nthreads;
static struct Thread_T root;
static T join0;
static T freelist;
const Except_T Thread_Alerted = { "Thread alerted" };
const Except_T Thread_Failed =
{ "Thread creation failed" };
static int critical;
extern void _swtch(T from, T to);
static void put(T t, T *q) {
assert(t);
assert(t->inqueue == NULL && t->link == NULL);
if (*q) {
t->link = (*q)->link;
(*q)->link = t;
} else
t->link = t;
*q = t;
t->inqueue = q;
}
static T get(T *q) {
T t;
assert(!isempty(*q));
t = (*q)->link;
if (t == *q)
*q = NULL;
else
(*q)->link = t->link;
assert(t->inqueue == q);
t->link = NULL;
t->inqueue = NULL;
return t;
}
static void delete(T t, T *q) {
T p;
assert(t->link && t->inqueue == q);
assert(!isempty(*q));
for (p = *q; p->link != t; p = p->link)
;
if (p == t)
*q = NULL;
else {
p->link = t->link;
if (*q == t)
*q = p;
}
t->link = NULL;
t->inqueue = NULL;
}
static void run(void) {
T t = current;
current = get(&ready);
t->estack = Except_stack;
Except_stack = current->estack;
_swtch(t, current);
}
static void testalert(void) {
if (current->alerted) {
current->alerted = 0;
RAISE(Thread_Alerted);
}
}
static void release(void) {
T t;
do { critical++;
while ((t = freelist) != NULL) {
freelist = t->next;
FREE(t);
}
critical--; } while (0);
}
#if linux
#include
static int interrupt(int sig, struct sigcontext sc) {
if (critical ||
sc.eip >= (unsigned long)_MONITOR
&& sc.eip <= (unsigned long)_ENDMONITOR)
return 0;
put(current, &ready);
do { critical++;
sigsetmask(sc.oldmask);
critical--; } while (0);
run();
return 0;
}
#else
#if __APPLE__
#define sc_pc sc_eip
#endif
static int interrupt(int sig, int code,
struct sigcontext *scp) {
if (critical ||
scp->sc_pc >= (unsigned long)_MONITOR
&& scp->sc_pc <= (unsigned long)_ENDMONITOR)
return 0;
put(current, &ready);
do { critical++;
sigsetmask(scp->sc_mask);
critical--; } while (0);
run();
return 0;
}
#endif
int Thread_init(int preempt, ...) {
assert(preempt == 0 || preempt == 1);
assert(current == NULL);
root.handle = &root;
current = &root;
nthreads = 1;
if (preempt) {
{
struct sigaction sa;
memset(&sa, '\0', sizeof sa);
sa.sa_handler = (void (*)())interrupt;
if (sigaction(SIGVTALRM, &sa, NULL) < 0)
return 0;
}
{
struct itimerval it;
it.it_value.tv_sec = 0;
it.it_value.tv_usec = 10;
it.it_interval.tv_sec = 0;
it.it_interval.tv_usec = 10;
if (setitimer(ITIMER_VIRTUAL, &it, NULL) < 0)
return 0;
}
}
return 1;
}
T Thread_self(void) {
assert(current);
return current;
}
void Thread_pause(void) {
assert(current);
put(current, &ready);
run();
}
int Thread_join(T t) {
assert(current && t != current);
testalert();
if (t) {
if (t->handle == t) {
put(current, &t->join);
run();
testalert();
return current->code;
} else
return -1;
} else {
assert(isempty(join0));
if (nthreads > 1) {
put(current, &join0);
run();
testalert();
}
return 0;
}
}
void Thread_exit(int code) {
assert(current);
release();
if (current != &root) {
current->next = freelist;
freelist = current;
}
current->handle = NULL;
while (!isempty(current->join)) {
T t = get(¤t->join);
t->code = code;
put(t, &ready);
}
if (!isempty(join0) && nthreads == 2) {
assert(isempty(ready));
put(get(&join0), &ready);
}
if (--nthreads == 0)
exit(code);
else
run();
}
void Thread_alert(T t) {
assert(current);
assert(t && t->handle == t);
t->alerted = 1;
if (t->inqueue) {
delete(t, t->inqueue);
put(t, &ready);
}
}
T Thread_new(int apply(void *), void *args,
int nbytes, ...) {
T t;
assert(current);
assert(apply);
assert(args && nbytes >= 0 || args == NULL);
if (args == NULL)
nbytes = 0;
{
int stacksize = (16*1024+sizeof (*t)+nbytes+15)&~15;
release();
do { critical++;
TRY
t = ALLOC(stacksize);
memset(t, '\0', sizeof *t);
EXCEPT(Mem_Failed)
t = NULL;
END_TRY;
critical--; } while (0);
if (t == NULL)
RAISE(Thread_Failed);
t->sp = (void *)(((unsigned long)t + stacksize)&~15U);
}
t->handle = t;
if (nbytes > 0) {
t->sp -= ((nbytes + 15U)&~15)/sizeof (*t->sp);
do { critical++;
memcpy(t->sp, args, nbytes);
critical--; } while (0);
args = t->sp;
}
#if alpha
{ extern void _start(void);
t->sp -= 112/8;
t->sp[(48+24)/8] = (unsigned long)Thread_exit;
t->sp[(48+16)/8] = (unsigned long)args;
t->sp[(48+ 8)/8] = (unsigned long)apply;
t->sp[(48+ 0)/8] = (unsigned long)_start; }
#elif mips
{ extern void _start(void);
t->sp -= 16/4;
t->sp -= 88/4;
t->sp[(48+20)/4] = (unsigned long)Thread_exit;
t->sp[(48+28)/4] = (unsigned long)args;
t->sp[(48+32)/4] = (unsigned long)apply;
t->sp[(48+36)/4] = (unsigned long)_start; }
#elif sparc
{ int i; void *fp; extern void _start(void);
for (i = 0; i < 8; i++)
*--t->sp = 0;
*--t->sp = (unsigned long)args;
*--t->sp = (unsigned long)apply;
t->sp -= 64/4;
fp = t->sp;
*--t->sp = (unsigned long)_start - 8;
*--t->sp = (unsigned long)fp;
t->sp -= 64/4; }
#elif (linux || __APPLE__) && i386
{ extern void _thrstart(void);
t->sp -= 16/4; /* keep stack aligned to 16-byte boundaries */
*t->sp = (unsigned long)_thrstart;
t->sp -= 16/4;
t->sp[4/4] = (unsigned long)apply;
t->sp[8/4] = (unsigned long)args;
t->sp[12/4] = (unsigned long)t->sp + (4+16)/4; }
#else
Unsupported platform
#endif
nthreads++;
put(t, &ready);
return t;
}
#undef T
#define T Sem_T
T *Sem_new(int count) {
T *s;
NEW(s);
Sem_init(s, count);
return s;
}
void Sem_init(T *s, int count) {
assert(current);
assert(s);
s->count = count;
s->queue = NULL;
}
void Sem_wait(T *s) {
assert(current);
assert(s);
testalert();
if (s->count <= 0) {
put(current, (Thread_T *)&s->queue);
run();
testalert();
} else
--s->count;
}
void Sem_signal(T *s) {
assert(current);
assert(s);
if (s->count == 0 && !isempty(s->queue)) {
Thread_T t = get((Thread_T *)&s->queue);
assert(!t->alerted);
put(t, &ready);
} else
++s->count;
}
#undef T
eisl-5.55/cii/src/xp.c 0000664 0000000 0000000 00000012417 15066676224 0014555 0 ustar 00root root 0000000 0000000 static char rcsid[] = "$Id$";
#include
#include
#include "assert.h"
#include "xp.h"
#define T XP_T
#define BASE (1<<8)
static char map[] = {
0, 1, 2, 3, 4, 5, 6, 7, 8, 9,
36, 36, 36, 36, 36, 36, 36,
10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22,
23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35,
36, 36, 36, 36, 36, 36,
10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22,
23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35
};
unsigned long XP_fromint(int n, T z, unsigned long u) {
int i = 0;
do
z[i++] = u%BASE;
while ((u /= BASE) > 0 && i < n);
for ( ; i < n; i++)
z[i] = 0;
return u;
}
unsigned long XP_toint(int n, T x) {
unsigned long u = 0;
int i = (int)sizeof u;
if (i > n)
i = n;
while (--i >= 0)
u = BASE*u + x[i];
return u;
}
int XP_length(int n, T x) {
while (n > 1 && x[n-1] == 0)
n--;
return n;
}
int XP_add(int n, T z, T x, T y, int carry) {
int i;
for (i = 0; i < n; i++) {
carry += x[i] + y[i];
z[i] = carry%BASE;
carry /= BASE;
}
return carry;
}
int XP_sub(int n, T z, T x, T y, int borrow) {
int i;
for (i = 0; i < n; i++) {
int d = (x[i] + BASE) - borrow - y[i];
z[i] = d%BASE;
borrow = 1 - d/BASE;
}
return borrow;
}
int XP_sum(int n, T z, T x, int y) {
int i;
for (i = 0; i < n; i++) {
y += x[i];
z[i] = y%BASE;
y /= BASE;
}
return y;
}
int XP_diff(int n, T z, T x, int y) {
int i;
for (i = 0; i < n; i++) {
int d = (x[i] + BASE) - y;
z[i] = d%BASE;
y = 1 - d/BASE;
}
return y;
}
int XP_neg(int n, T z, T x, int carry) {
int i;
for (i = 0; i < n; i++) {
carry += (unsigned char)~x[i];
z[i] = carry%BASE;
carry /= BASE;
}
return carry;
}
int XP_mul(T z, int n, T x, int m, T y) {
int i, j, carryout = 0;
for (i = 0; i < n; i++) {
unsigned carry = 0;
for (j = 0; j < m; j++) {
carry += x[i]*y[j] + z[i+j];
z[i+j] = carry%BASE;
carry /= BASE;
}
for ( ; j < n + m - i; j++) {
carry += z[i+j];
z[i+j] = carry%BASE;
carry /= BASE;
}
carryout |= carry;
}
return carryout;
}
int XP_product(int n, T z, T x, int y) {
int i;
unsigned carry = 0;
for (i = 0; i < n; i++) {
carry += x[i]*y;
z[i] = carry%BASE;
carry /= BASE;
}
return carry;
}
int XP_div(int n, T q, T x, int m, T y, T r, T tmp) {
int nx = n, my = m;
n = XP_length(n, x);
m = XP_length(m, y);
if (m == 1) {
if (y[0] == 0)
return 0;
r[0] = XP_quotient(nx, q, x, y[0]);
memset(r + 1, '\0', my - 1);
} else if (m > n) {
memset(q, '\0', nx);
memcpy(r, x, n);
memset(r + n, '\0', my - n);
} else {
int k;
unsigned char *rem = tmp, *dq = tmp + n + 1;
assert(2 <= m && m <= n);
memcpy(rem, x, n);
rem[n] = 0;
for (k = n - m; k >= 0; k--) {
int qk;
{
int i;
assert(2 <= m && m <= k+m && k+m <= n);
{
int km = k + m;
unsigned long y2 = y[m-1]*BASE + y[m-2];
unsigned long r3 = rem[km]*(BASE*BASE) +
rem[km-1]*BASE + rem[km-2];
qk = r3/y2;
if (qk >= BASE)
qk = BASE - 1;
}
dq[m] = XP_product(m, dq, y, qk);
for (i = m; i > 0; i--)
if (rem[i+k] != dq[i])
break;
if (rem[i+k] < dq[i])
dq[m] = XP_product(m, dq, y, --qk);
}
q[k] = qk;
{
int borrow;
assert(0 <= k && k <= k+m);
borrow = XP_sub(m + 1, &rem[k], &rem[k], dq, 0);
assert(borrow == 0);
}
}
memcpy(r, rem, m);
{
int i;
for (i = n-m+1; i < nx; i++)
q[i] = 0;
for (i = m; i < my; i++)
r[i] = 0;
}
}
return 1;
}
int XP_quotient(int n, T z, T x, int y) {
int i;
unsigned carry = 0;
for (i = n - 1; i >= 0; i--) {
carry = carry*BASE + x[i];
z[i] = carry/y;
carry %= y;
}
return carry;
}
int XP_cmp(int n, T x, T y) {
int i = n - 1;
while (i > 0 && x[i] == y[i])
i--;
return x[i] - y[i];
}
void XP_lshift(int n, T z, int m, T x, int s, int fill) {
fill = fill ? 0xFF : 0;
{
int i, j = n - 1;
if (n > m)
i = m - 1;
else
i = n - s/8 - 1;
for ( ; j >= m + s/8; j--)
z[j] = 0;
for ( ; i >= 0; i--, j--)
z[j] = x[i];
for ( ; j >= 0; j--)
z[j] = fill;
}
s %= 8;
if (s > 0)
{
XP_product(n, z, z, 1<>(8-s);
}
}
void XP_rshift(int n, T z, int m, T x, int s, int fill) {
fill = fill ? 0xFF : 0;
{
int i, j = 0;
for (i = s/8; i < m && j < n; i++, j++)
z[j] = x[i];
for ( ; j < n; j++)
z[j] = fill;
}
s %= 8;
if (s > 0)
{
XP_quotient(n, z, z, 1<= 2 && base <= 36);
while (*p && isspace(*p))
p++;
if ((*p && isalnum(*p) && map[*p-'0'] < base)) {
int carry;
for ( ; (*p && isalnum(*p) && map[*p-'0'] < base); p++) {
carry = XP_product(n, z, z, base);
if (carry)
break;
XP_sum(n, z, z, map[*p-'0']);
}
if (end)
*end = (char *)p;
return carry;
} else {
if (end)
*end = (char *)str;
return 0;
}
}
char *XP_tostr(char *str, int size, int base,
int n, T x) {
int i = 0;
assert(str);
assert(base >= 2 && base <= 36);
do {
int r = XP_quotient(n, x, x, base);
assert(i < size);
str[i++] =
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"[r];
while (n > 1 && x[n-1] == 0)
n--;
} while (n > 1 || x[0] != 0);
assert(i < size);
str[i] = '\0';
{
int j;
for (j = 0; j < --i; j++) {
char c = str[j];
str[j] = str[i];
str[i] = c;
}
}
return str;
}
eisl-5.55/compat/ 0000775 0000000 0000000 00000000000 15066676224 0013705 5 ustar 00root root 0000000 0000000 eisl-5.55/compat/cdefs.h 0000664 0000000 0000000 00000000526 15066676224 0015145 0 ustar 00root root 0000000 0000000 /* Wrapper around BSD sys/cdefs.h annotations */
#ifndef COMPAT_CDEFS_H
#define COMPAT_CDEFS_H
#ifndef __dead
#define __dead \
__attribute__((__noreturn__))
#endif
#ifndef __unused
#define __unused \
__attribute__((__unused__))
#endif
#ifndef __packed
#define __packed \
__attribute__((__packed__))
#endif
#endif
eisl-5.55/compat/curses_stubs.h 0000664 0000000 0000000 00000000132 15066676224 0016576 0 ustar 00root root 0000000 0000000 #ifndef COMPAT_CURSES_STUBS_H
#define COMPAT_CURSES_STUBS_H
#endif
#include
eisl-5.55/compat/eiffel_stubs.h 0000664 0000000 0000000 00000000234 15066676224 0016527 0 ustar 00root root 0000000 0000000 #ifndef COMPAT_EIFFEL_STUBS_H
#define COMPAT_EIFFEL_STUBS_H
#ifdef WITH_NANA
#include "eiffel.h"
#else
#define REQUIRE(x)
#define ENSURE(x)
#endif
#endif
eisl-5.55/compat/nana_stubs.h 0000664 0000000 0000000 00000000220 15066676224 0016205 0 ustar 00root root 0000000 0000000 #ifndef COMPAT_NANA_STUBS_H
#define COMPAT_NANA_STUBS_H
#ifdef WITH_NANA
#include "nana.h"
#else
#define IP(x, y)
#define VL(x)
#endif
#endif
eisl-5.55/compat/term_stubs.h 0000664 0000000 0000000 00000000710 15066676224 0016243 0 ustar 00root root 0000000 0000000 #ifndef COMPAT_TERM_STUBS_H
#define COMPAT_TERM_STUBS_H
#ifdef WITHOUT_CURSES
#define COLOR_RED 0
#define COLOR_CYAN 0
#define COLOR_MAGENTA 0
#define COLOR_YELLOW 0
#define COLOR_BLUE 0
#define ERR 0
#define tputs(x, y, z)
#define putp(x)
#define setupterm(x, y, z) (ERR)
static const char *key_up = NULL;
static const char *key_down = NULL;
static const char *key_right = NULL;
static const char *key_left = NULL;
#else
#include
#endif
#endif
eisl-5.55/compute.c 0000664 0000000 0000000 00000052000 15066676224 0014237 0 ustar 00root root 0000000 0000000 #include
#include
#include
#include
#include "eisl.h"
/* data type transfer */
int exact_to_inexact(int x)
{
int res, tag;
double val;
tag = GET_TAG(x);
switch (tag) {
case INTN:
res = freshcell();
SET_TAG(res, FLTN);
val = (double) GET_INT(x);
SET_FLT(res, val);
return (res);
case LONGN:
res = freshcell();
SET_TAG(res, FLTN);
val = (double) GET_LONG(x);
SET_FLT(res, val);
return (res);
case BIGN:
return (big_big_to_flt(x));
case FLTN:
return (x);
default:
return (x);
}
error(OUT_OF_RANGE, "exact_to_inexact", x, 0);
return (UNDEF);
}
int numeqp(int x, int y)
{
int x1, y1;
/* if integer type and address are same, then true. */
if (integerp(x) && integerp(y)) {
if (GET_INT(x) == GET_INT(y))
return (1);
else
return (0);
}
/* if long integer data type and the values are same, then true. */
else if (longnump(x) && longnump(y)) {
if (GET_LONG(x) == GET_LONG(y))
return (1);
else
return (0);
}
else if (bignump(x) && bignump(y)) {
if (big_eqp(x, y))
return (1);
else
return (0);
}
/* if floating point number, consider EPSILON */
else if (floatp(x) && floatp(y)) {
if (GET_FLT(x) - DBL_EPSILON <= GET_FLT(y) &&
GET_FLT(x) + DBL_EPSILON >= GET_FLT(y))
return (1);
else if (GET_FLT(x) >= GET_FLT(y) - DBL_EPSILON &&
GET_FLT(x) <= GET_FLT(y) + DBL_EPSILON)
return (1);
/* when huge number */
else if (fabs(GET_FLT(x)) > 1e+30
&& fabs(GET_FLT(x) - GET_FLT(y)) <
fabs(GET_FLT(x)) / 100000)
return (1);
else
return (0);
} else {
x1 = exact_to_inexact(x);
y1 = exact_to_inexact(y);
if (GET_FLT(x1) - DBL_EPSILON <= GET_FLT(y1) &&
GET_FLT(x1) + DBL_EPSILON >= GET_FLT(y1))
return (1);
else if (GET_FLT(x1) >= GET_FLT(y1) - DBL_EPSILON &&
GET_FLT(x1) <= GET_FLT(y1) - DBL_EPSILON)
return (1);
else
return (0);
}
}
int smallerp(int x1, int x2)
{
if (IS_INTEGER(x1) && IS_INTEGER(x2)) {
if (GET_INT(x1) < GET_INT(x2))
return (1);
else
return (0);
} else if (integerp(x1) && bignump(x2))
return (1);
else if (longnump(x1) && bignump(x2))
return (1);
else if (longnump(x1) && longnump(x2)) {
if (GET_LONG(x1) < GET_LONG(x2))
return (1);
else
return (0);
} else if (bignump(x1) && bignump(x2)) {
if (big_smallerp(x1, x2))
return (1);
else
return (0);
} else {
if (GET_FLT(exact_to_inexact(x1)) < GET_FLT(exact_to_inexact(x2)))
return (1);
else
return (0);
}
}
int eqsmallerp(int x1, int x2)
{
if (integerp(x1) && integerp(x2)) {
if (GET_INT(x1) <= GET_INT(x2))
return (1);
else
return (0);
} else if (integerp(x1) && bignump(x2))
return (1);
else if (longnump(x1) && bignump(x2))
return (1);
else if (longnump(x1) && longnump(x2)) {
if (GET_LONG(x1) <= GET_LONG(x2))
return (1);
else
return (0);
} else if (bignump(x1) && bignump(x2)) {
if (big_smallerp(x1, x2) || big_eqp(x1, x2))
return (1);
else
return (0);
} else {
if (GET_FLT(exact_to_inexact(x1)) <= GET_FLT(exact_to_inexact(x2)))
return (1);
else
return (0);
}
}
int greaterp(int x1, int x2)
{
if (smallerp(x2, x1))
return (1);
else
return (0);
}
int eqgreaterp(int x1, int x2)
{
if (eqsmallerp(x2, x1))
return (1);
else
return (0);
}
int positivep(int x)
{
if (integerp(x) && GET_INT(x) > 0)
return (1);
else if (longnump(x) && GET_LONG(x) > 0)
return (1);
else if (bignump(x) && big_positivep(x))
return (1);
else if (floatp(x) && GET_FLT(x) > 0)
return (1);
else
return (0);
}
int negativep(int x)
{
if (integerp(x) && GET_INT(x) < 0)
return (1);
else if (longnump(x) && GET_LONG(x) < 0)
return (1);
else if (bignump(x) && big_negativep(x))
return (1);
else if (floatp(x) && GET_FLT(x) < 0)
return (1);
else
return (0);
}
int zerop(int x)
{
if (integerp(x) && GET_INT(x) == 0)
return (1);
else if (floatp(x) && GET_FLT(x) == 0.0)
return (1);
else
return (0);
}
int positive_zerop(int x)
{
if (zerop(x) && floatp(x) && !signbit(GET_FLT(x)))
return (1);
else if (zerop(x) && floatp(x))
return (1);
else
return (0);
}
int negative_zerop(int x)
{
if (zerop(x) && floatp(x) && signbit(GET_FLT(x)))
return (1);
else
return (0);
}
/*
* basic operation
*/
int plus(int arg1, int arg2)
{
int tag1, tag2;
double x1, x2;
tag1 = GET_TAG(arg1);
tag2 = GET_TAG(arg2);
switch (tag1) {
case INTN:
switch (tag2) {
case INTN:
{
long long int l;
l = (long long int) GET_INT(arg1) +
(long long int) GET_INT(arg2);
if (SMALL_INT_MIN < l && l < SMALL_INT_MAX)
return (make_int((int) l));
else
return (make_long(l));
}
case FLTN:
return (plus(exact_to_inexact(arg1), arg2));
case LONGN:
return (big_plus(big_int_to_big(arg1), big_long_to_big(arg2)));
case BIGN:
return (big_plus(big_int_to_big(arg1), arg2));
}
break;
case LONGN:
switch (tag2) {
case INTN:
return (big_plus(big_long_to_big(arg1), big_int_to_big(arg2)));
case FLTN:
return (plus(exact_to_inexact(arg1), arg2));
case LONGN:
return (big_plus
(big_long_to_big(arg1), big_long_to_big(arg2)));
case BIGN:
return (big_plus(big_long_to_big(arg1), arg2));
}
break;
case BIGN:
switch (tag2) {
case INTN:
return (big_plus(arg1, big_int_to_big(arg2)));
case FLTN:
return (plus(exact_to_inexact(arg1), arg2));
case LONGN:
return (big_plus(arg1, big_long_to_big(arg2)));
case BIGN:
return (big_plus(arg1, arg2));
}
break;
case FLTN:
switch (tag2) {
case FLTN:
{
x1 = GET_FLT(arg1);
x2 = GET_FLT(arg2);
double y = x1 + x2;
if (fabs(y) > DBL_MAX)
error(FLT_OVERF, "+", list2(arg1, arg2), 0);
return (make_flt(y));
}
case INTN:
case LONGN:
case BIGN:
return (plus(arg1, exact_to_inexact(arg2)));
}
break;
default:
break;
}
error(NOT_COMPUTABLE, "+", list2(arg1, arg2), 0);
return (UNDEF);
}
int minus(int arg1, int arg2)
{
int tag1, tag2;
double x1, x2;
tag1 = GET_TAG(arg1);
tag2 = GET_TAG(arg2);
switch (tag1) {
case INTN:
switch (tag2) {
case INTN:
{
long long int l;
l = (long long int) GET_INT(arg1) -
(long long int) GET_INT(arg2);
if (SMALL_INT_MIN < l && l < SMALL_INT_MAX)
return (make_int((int) l));
else
return (make_long(l));
}
case FLTN:
{
return minus(exact_to_inexact(arg1), arg2);
}
case LONGN:
return (big_minus
(big_int_to_big(arg1), big_long_to_big(arg2)));
case BIGN:
return (big_minus(big_int_to_big(arg1), arg2));
}
break;
case LONGN:
switch (tag2) {
case INTN:
return (big_minus
(big_long_to_big(arg1), big_int_to_big(arg2)));
case FLTN:
return (minus(exact_to_inexact(arg1), arg2));
case LONGN:
return (big_minus
(big_long_to_big(arg1), big_long_to_big(arg2)));
case BIGN:
return (big_minus(big_long_to_big(arg1), arg2));
}
break;
case BIGN:
switch (tag2) {
case INTN:
return (big_minus(arg1, big_int_to_big(arg2)));
case FLTN:
return (minus(exact_to_inexact(arg1), arg2));
case LONGN:
return (big_minus(arg1, big_long_to_big(arg2)));
case BIGN:
return (big_minus(arg1, arg2));
}
break;
case FLTN:
switch (tag2) {
case FLTN:
{
x1 = GET_FLT(arg1);
x2 = GET_FLT(arg2);
double y = x1 - x2;
if (fabs(y) > DBL_MAX)
error(FLT_OVERF, "-", list2(arg1, arg2), 0);
return (make_flt(y));
}
case INTN:
case LONGN:
case BIGN:
return (minus(arg1, exact_to_inexact(arg2)));
}
break;
}
error(NOT_COMPUTABLE, "-", list2(arg1, arg2), 0);
return (UNDEF);
}
int mult(int arg1, int arg2)
{
int tag1, tag2;
double x1, y1, x2;
tag1 = GET_TAG(arg1);
tag2 = GET_TAG(arg2);
switch (tag1) {
case INTN:
switch (tag2) {
case INTN:
{
long long int l1, l2, l;
l1 = (long long int) GET_INT(arg1);
l2 = (long long int) GET_INT(arg2);
l = l1 * l2;
if (l < SMALL_INT_MAX && l > SMALL_INT_MIN)
return (make_int((int) l));
else
return (big_mult
(big_int_to_big(arg1), big_int_to_big(arg2)));
}
case FLTN:
{
return mult(exact_to_inexact(arg1), arg2);
}
case LONGN:
if (GET_INT(arg1) != 0)
return (big_mult
(big_long_to_big(arg2), big_int_to_big(arg1)));
else
return (arg1); /* int 0 */
case BIGN:
return (big_mult(arg2, big_int_to_big(arg1)));
}
break;
case LONGN:
switch (tag2) {
case INTN:
if (GET_INT(arg2) != 0)
return (big_mult
(big_long_to_big(arg1), big_int_to_big(arg2)));
else
return (arg2); /* int 0 */
case FLTN:
return (mult(exact_to_inexact(arg1), arg2));
case LONGN:
return (big_mult
(big_long_to_big(arg1), big_long_to_big(arg2)));
case BIGN:
return (big_mult(big_long_to_big(arg1), arg2));
}
break;
case BIGN:
switch (tag2) {
case INTN:
return (big_mult_i(arg1, arg2));
case FLTN:
return (mult(exact_to_inexact(arg1), arg2));
case LONGN:
return (big_mult(arg1, big_long_to_big(arg2)));
case BIGN:
return (big_mult(arg1, arg2));
}
break;
case FLTN:
switch (tag2) {
case FLTN:
{
x1 = GET_FLT(arg1);
x2 = GET_FLT(arg2);
y1 = x1 * x2;
if (y1 > DBL_MAX || y1 < -DBL_MAX)
error(FLT_OVERF, "*", list2(arg1, arg2), 0);
if (x1 != 0.0 && x2 != 0.0 && y1 > -DBL_MIN
&& y1 < DBL_MIN)
error(FLT_UNDERF, "*", list2(arg1, arg2), 0);
return (make_flt(y1));
}
case INTN:
case LONGN:
case BIGN:
return (mult(arg1, exact_to_inexact(arg2)));
}
break;
}
error(NOT_COMPUTABLE, "*", list2(arg1, arg2), 0);
return (UNDEF);
}
int quotient(int arg1, int arg2)
{
int n, s, tag1, tag2;
double x1, y1, x2;
if (zerop(arg2))
error(DIV_ZERO, "quotient", arg2, 0);
tag1 = GET_TAG(arg1);
tag2 = GET_TAG(arg2);
switch (tag1) {
case INTN:
switch (tag2) {
case INTN:
{
n = GET_INT(arg1);
if (n == 0)
return (arg1);
x1 = (double) n;
s = GET_INT(arg2);
y1 = (double) s;
x2 = x1 / y1;
if ((x2 - floor(x2)) == 0.0)
return (make_int((int) x2));
else
return (make_flt(x1 / y1));
}
case FLTN:
return quotient(exact_to_inexact(arg1), arg2);
case LONGN:
case BIGN:
if (GET_INT(arg1) == 0)
return (arg1);
else
return (quotient
(exact_to_inexact(arg1), exact_to_inexact(arg2)));
}
break;
case LONGN:
switch (tag2) {
case INTN:
case LONGN:
n = quotient(exact_to_inexact(arg1), exact_to_inexact(arg2));
x1 = GET_FLT(n);
x2 = x1 - ceil(x1);
if (x2 == 0.0) {
return (divide(arg1, arg2));
} else
return (n);
case BIGN:
return (quotient
(exact_to_inexact(arg1), exact_to_inexact(arg2)));
case FLTN:
return (quotient(exact_to_inexact(arg1), arg2));
}
break;
case BIGN:
switch (tag2) {
case INTN:
case LONGN:
case BIGN:
n = quotient(exact_to_inexact(arg1), exact_to_inexact(arg2));
x1 = GET_FLT(n);
x2 = x1 - ceil(x1);
if (x1 == 1.0)
return (make_int(1));
else if (x1 == -1.0)
return (make_int(-1));
else if (x2 == 0.0)
return (divide(arg1, arg2));
else
return (n);
case FLTN:
return (quotient(exact_to_inexact(arg1), arg2));
}
break;
case FLTN:
switch (tag2) {
case FLTN:
{
x1 = GET_FLT(arg1);
x2 = GET_FLT(arg2);
y1 = x1 / x2;
if (fabs(y1) > DBL_MAX)
error(FLT_OVERF, "quotient", list2(arg1, arg2), 0);
if (x1 != 0.0 && x2 != 0.0 && fabs(y1) < DBL_MIN)
error(FLT_UNDERF, "quotient", list2(arg1, arg2), 0);
return make_flt(y1);
}
case INTN:
case LONGN:
case BIGN:
return (quotient(arg1, exact_to_inexact(arg2)));
}
break;
}
error(NOT_COMPUTABLE, "/", list2(arg1, arg2), 0);
return (UNDEF);
}
int divide(int x, int y)
{
if (integerp(x) && longnump(y))
return (make_int(0));
else if (integerp(x) && bignump(y))
return (make_int(0));
else if (longnump(x) && bignump(y))
return (make_int(0));
else if (integerp(x) && integerp(y))
return (make_int(GET_INT(x) / GET_INT(y)));
else if (longnump(x) && integerp(y))
return (long_int_div(x, y));
else if (longnump(x) && longnump(y))
return (long_long_div(x, y));
else if (bignump(x) && integerp(y))
return (big_div_i(x, y));
else if (bignump(x) && longnump(y))
return (big_div(x, big_long_to_big(y)));
else if (bignump(x) && bignump(y))
return (big_div(x, y));
else
error(ILLEGAL_ARGS, "div", list2(x, y), 0);
return (UNDEF);
}
int s_remainder(int x, int y)
{
int i;
if (integerp(x) && integerp(y))
return (make_int(GET_INT(x) % GET_INT(y)));
else if (integerp(x) && longnump(y))
return (x);
else if (integerp(x) && bignump(y))
return (x);
else if (longnump(x) && bignump(y))
return (x);
else if (longnump(x) && integerp(y))
return (long_int_remainder(x, y));
else if (longnump(x) && longnump(y))
return (long_long_remainder(x, y));
else if (bignump(x) && integerp(y))
return (big_remainder_i(x, y));
else if (bignump(x) && longnump(y)) {
i = big_long_to_big(y);
return (minus(x, mult(divide(x, i), i)));
} else if (bignump(x) && bignump(y))
return (big_remainder(x, y));
error(ILLEGAL_ARGS, "remainder", NIL, 0);
return (UNDEF);
}
/* remainder of longnum and int. */
int long_int_remainder(int x, int y)
{
long long int m, n, r;
m = GET_LONG(x);
n = (long long int) GET_INT(y);
r = m % n;
return (make_int((int) r));
}
/* remainder of longnum and longnum. */
int long_long_remainder(int x, int y)
{
long long int m, n, r;
m = GET_LONG(x);
n = GET_LONG(y);
r = m % n;
if (llabs(r) < BIGNUM_BASE)
return (make_int((int) r));
else
return (make_long(r));
}
/* divide of longnum and int. */
int long_int_div(int x, int y)
{
long long int m, n, q;
m = GET_LONG(x);
n = (long long int) GET_INT(y);
q = m / n;
if (llabs(q) < BIGNUM_BASE)
return (make_int((int) q));
else
return (make_long(q));
}
/* divide of longnum and longnum */
int long_long_div(int x, int y)
{
long long int m, n, q;
m = GET_LONG(x);
n = GET_LONG(y);
q = m / n;
if (llabs(q) < BIGNUM_BASE)
return (make_int((int) q));
else
return (make_long(q));
}
int absolute(int x)
{
if (integerp(x))
return (make_int(abs(GET_INT(x))));
else if (longnump(x))
return (make_long(llabs(GET_LONG(x))));
else if (bignump(x)) {
return (big_abs(x));
} else if (floatp(x)) {
return (make_flt(fabs(GET_FLT(x))));
}
error(ILLEGAL_ARGS, "abs", x, 0);
return (UNDEF);
}
int angle(int y, int x)
{
if (positive_zerop(y) && positivep(x))
return (make_flt(0.0));
else if (negative_zerop(y) && positivep(x))
return (make_flt(-0.0));
else if (positivep(y) && positivep(x))
return (make_flt
(atan
(GET_FLT(exact_to_inexact(y)) /
GET_FLT(exact_to_inexact(x)))));
else if (positivep(y) && zerop(x))
return (make_flt(M_PI_2));
else if (positivep(y) && negativep(x))
return (make_flt
(M_PI +
atan(GET_FLT(exact_to_inexact(y)) /
GET_FLT(exact_to_inexact(x)))));
else if (positive_zerop(y) && negativep(x))
return (make_flt(M_PI));
else if (negative_zerop(y) && negativep(x))
return (make_flt(-M_PI));
else if (negativep(y) && negativep(x))
return (make_flt
(-M_PI +
atan(GET_FLT(exact_to_inexact(y)) /
GET_FLT(exact_to_inexact(x)))));
else if (negativep(y) && zerop(x))
return (make_flt(-M_PI_2));
else if (negativep(y) && positivep(x))
return (make_flt
(atan
(GET_FLT(exact_to_inexact(y)) /
GET_FLT(exact_to_inexact(x)))));
else if (zerop(y) && positivep(x))
return (make_flt(0.0));
else if (zerop(y) && negativep(x))
return (make_flt(M_PI));
else if (positive_zerop(y) && positive_zerop(x))
return (make_flt(+0.0));
else if (negative_zerop(y) && positive_zerop(x))
return (make_flt(-0.0));
else if (positive_zerop(y) && negative_zerop(x))
return (make_flt(M_PI));
else if (negative_zerop(y) && negative_zerop(x))
return (make_flt(-M_PI));
else if (positive_zerop(y) && zerop(x))
return (make_flt(M_PI_2));
else if (negative_zerop(y) && zerop(x))
return (make_flt(-M_PI_2));
else {
error(ILLEGAL_ARGS, "angle", list2(x, y), 0);
return (UNDEF);
}
}
/* GCD of integer */
int int_gcd(int x, int y)
{
if (y == 0)
return (x);
while (y != 0) {
int r;
r = x % y;
x = y;
y = r;
}
return (x);
}
/* GCD of number(include bignum) */
int gcd(int x, int y)
{
if (integerp(x) && integerp(y))
return (make_int(abs(int_gcd(GET_INT(x), GET_INT(y)))));
else if (floatp(x) && integerp(y))
return (make_flt
((double) abs(int_gcd((int) GET_FLT(x), GET_INT(y)))));
else if (integerp(x) && floatp(y))
return (make_flt
((double) abs(int_gcd(GET_INT(x), (int) GET_FLT(y)))));
else if (floatp(x) && floatp(y))
return (make_flt
((double) abs(int_gcd(GET_FLT(x), (int) GET_FLT(y)))));
if (smallerp(x, y)) {
int temp;
temp = x;
x = y;
y = temp;
}
while (!zerop(y)) {
int r;
r = f_mod(list2(x, y), 0); // gcd for bugnum is not thread safety
x = y;
y = r;
}
return (absolute(x));
}
/* LCM of integer */
int int_lcm(int m, int n)
{
if (m == 0 || n == 0)
return (0);
return ((m / int_gcd(m, n)) * n);
}
/* LCM of number(include bignum) */
int lcm(int x, int y)
{
int g, d, res;
if (integerp(x) && integerp(y) && abs(GET_INT(x)) < 10000
&& abs(GET_INT(y)) < 10000)
// because x,y < sqrt(BIGNUM_BASE)
return (make_int(abs(int_lcm(GET_INT(x), GET_INT(y)))));
else if (floatp(x) && integerp(y))
return (make_flt
((double) abs(int_lcm((int) GET_FLT(x), GET_INT(y)))));
else if (integerp(x) && floatp(y))
return (make_flt
((double) abs(int_lcm(GET_INT(x), (int) GET_FLT(y)))));
else if (floatp(x) && floatp(y))
return (make_flt
((double) abs(int_lcm(GET_FLT(x), (int) GET_FLT(y)))));
else {
g = gcd(x, y);
d = divide(absolute(x), g);
res = mult(d, absolute(y));
return (res);
}
}
/* newton method for longnum */
long long int isqrt1(long long int n, long long int init)
{
long long int s;
s = init;
while (s * s > n) {
s = (s + n / s) / 2;
}
return (s);
}
/* newton method for bignum */
int isqrt2(int n, int init)
{
int s;
s = init;
while (greaterp(mult(s, s), n)) {
//print(s);printf("\n");
s = divide(plus(s, divide(n, s)), make_int(2));
}
return (s);
}
/* basic isqrt (for small bignum) */
int isqrt3(int x)
{
int len, pointer, init, i;
len = get_length(x);
pointer = get_pointer(x);
if (len % 2 == 0) {
long long int lmsb =
(long long int) bigcell[pointer] * BIGNUM_BASE +
(long long int) bigcell[pointer - 1];
init = gen_big();
len = (len - 2) / 2;
for (i = 0; i < len; i++) {
bigcell[big_pt0++] = 0;
}
bigcell[big_pt0++] = (int) sqrt(lmsb) + 10000;
set_sign(init, 1);
set_pointer(init, big_pt0 - 1);
set_length(init, len + 1);
} else {
int msb = bigcell[pointer];
init = gen_big();
len = (len - 1) / 2;
for (i = 0; i < len; i++) {
bigcell[big_pt0++] = 0;
}
bigcell[big_pt0++] = (int) sqrt(msb) + 1;
set_sign(init, 1);
set_pointer(init, big_pt0 - 1);
set_length(init, len + 1);
}
return (isqrt2(x, init));
}
/* idea memo
even digits
e.g. isqrt(12345678901234) = 3513641
goal init value
isqrt(123456) - 351
isqrt(123456789012) 35100 351364
isqrt(12345678901234) 3513640 3513641
e.g. isqrt(1234567890123) 1111111
odd digits
goal init value
isqrt(12345) - 111
isqrt(123456789) 11100 11111
isqrt(1234567890123) 1111100 1111111
size of bignum must be 10 or greater
*/
int isqrt4(int x)
{
int len, len1, len2, init, target, res;
len = get_length(x);
if (len % 2 == 0) {
len1 = 3;
len2 = 6;
init = plus(isqrt3(big_take_from_left(x, len2)), make_int(1));
while (len2 * 2 < len) {
len1 = len1 * 2;
len2 = len2 * 2;
target = big_take_from_left(x, len2);
init = big_shift_right(init, len1 - get_length(init));
init = plus(isqrt2(target, init), make_int(1));
}
len1 = len / 2;
len2 = len;
init = big_shift_right(init, len1 - get_length(init));
res = isqrt2(big_take_from_left(x, len2), init);
return (res);
} else {
len1 = 3;
len2 = 5;
init = plus(isqrt3(big_take_from_left(x, len2)), make_int(1));
while (len2 * 2 - 1 < len) {
len1 = len1 + ((len2 * 2 - 1) - len2) / 2;
len2 = len2 * 2 - 1;
target = big_take_from_left(x, len2);
init = big_shift_right(init, len1 - get_length(init));
init = plus(isqrt2(target, init), make_int(1));
}
len1 = (len + 1) / 2;
len2 = len;
init = big_shift_right(init, len1 - get_length(init));
res = isqrt2(big_take_from_left(x, len2), init);
return (res);
}
}
int isqrt(int x)
{
if (integerp(x))
return (make_int(floor(sqrt(GET_INT(x)))));
else if (floatp(x))
return (make_int(floor(sqrt(GET_FLT(x)))));
else if (longnump(x)) {
long long int n, init;
n = GET_LONG(x);
init = (long long int) sqrt(n) + 1;
return (make_int((int) isqrt1(n, init)));
} else {
if (get_length(x) < 10)
return (isqrt3(x));
else
return (isqrt4(x));
}
}
eisl-5.55/data.c 0000664 0000000 0000000 00000100720 15066676224 0013477 0 ustar 00root root 0000000 0000000 /*
* predicate for ISLisp data structures
* operation for data structures
*/
#include
#include
#include
#include
#include
#include "eisl.h"
#include "mem.h"
#include "fmt.h"
#include "compat/eiffel_stubs.h"
int get_int(int addr)
{
return (GET_INT(addr));
}
long long int get_long(int addr)
{
return (GET_LONG(addr));
}
int atomp(int addr)
{
if (!(IS_LIST(addr)))
return (1);
else
return (0);
}
int numberp(int addr)
{
if (IS_INTEGER(addr) || IS_FLOAT(addr) || IS_LONGNUM(addr)
|| IS_BIGNNUM(addr))
return (1);
else
return (0);
}
int integerp(int x)
{
if (IS_INTEGER(x))
return (1);
else
return (0);
}
int bignump(int x)
{
if (IS_BIGNNUM(x))
return (1);
else
return (0);
}
int longnump(int x)
{
if (IS_LONGNUM(x))
return (1);
else
return (0);
}
int floatp(int x)
{
if (IS_FLOAT(x))
return (1);
else
return (0);
}
int math_integerp(int addr)
{
if (IS_INTEGER(addr) || IS_LONGNUM(addr) || IS_BIGNNUM(addr))
return (1);
else
return (0);
}
DEF_PREDICATE(SYMBOL, SYM)
int symbolp(int addr)
{
if (IS_SYMBOL(addr))
return (1);
else
return (0);
}
int listp(int addr)
{
if (IS_LIST(addr) || IS_NIL(addr))
return (1);
else
return (0);
}
int nullp(int addr)
{
if (IS_NIL(addr))
return (1);
else
return (0);
}
int eqp(int addr1, int addr2)
{
if (addr1 == addr2)
return (1);
else
return (0);
}
int eqlp(int addr1, int addr2)
{
int i, n, ls;
if (addr1 == addr2)
return (1);
else if (numberp(addr1) && numberp(addr2) && math_integerp(addr1)
&& math_integerp(addr2))
return (numeqp(addr1, addr2));
else if (numberp(addr1) && numberp(addr2) && floatp(addr1)
&& floatp(addr2))
return (numeqp(addr1, addr2));
else if (((symbolp(addr1) && symbolp(addr2)))
&& (SAME_NAME(addr1, addr2)))
return (1);
else if (((charp(addr1) && charp(addr2))) && (SAME_NAME(addr1, addr2)))
return (1);
else if (((stringp(addr1) && stringp(addr2)))
&& (SAME_NAME(addr1, addr2)))
return (1);
else if (vectorp(addr1) && vectorp(addr2)) {
if (vector_length(addr1) == vector_length(addr2)) {
n = vector_length(addr1);
for (i = 0; i < n; i++)
if (!eqlp(GET_VEC_ELT(addr1, i), GET_VEC_ELT(addr2, i)))
return (0);
return (1);
} else
return (0);
} else if (arrayp(addr1) && arrayp(addr2)) {
if (equalp(array_length(addr1), array_length(addr2))) {
ls = array_length(addr1);
n = 1;
while (!nullp(ls)) {
n = n * GET_INT(car(ls));
ls = cdr(ls);
}
for (i = 0; i < n; i++)
if (!eqlp(GET_VEC_ELT(addr1, i), GET_VEC_ELT(addr2, i)))
return (0);
return (1);
} else
return (0);
}
return (0);
}
int equalp(int addr1, int addr2)
{
if (vectorp(addr1) && vectorp(addr2)) {
if (vector_length(addr1) == vector_length(addr2)) {
int i, n;
n = vector_length(addr1);
for (i = 0; i < n; i++) {
if (!equalp(GET_VEC_ELT(addr1, i), GET_VEC_ELT(addr2, i)))
return (0);
}
return (1);
} else
return (0);
} else if (atomp(addr1) && atomp(addr2))
return (eqlp(addr1, addr2));
else if (atomp(addr1) && !atomp(addr2))
return (0);
else if (!atomp(addr1) && atomp(addr2))
return (0);
else if (equalp(car(addr1), car(addr2)) &&
equalp(cdr(addr1), cdr(addr2)))
return (1);
else
return (0);
}
int subrp(int addr)
{
if (IS_SUBR(GET_CAR(addr)))
return (1);
else
return (0);
}
int fsubrp(int addr)
{
if (IS_FSUBR(GET_CAR(addr)))
return (1);
else
return (0);
}
int compiledp(int addr)
{
if (IS_COMPILED(GET_CAR(addr)))
return (1);
else
return (0);
}
int functionp(int addr)
{
int val;
val = find_dyn(addr, 0);
if ((val != -1) && IS_FUNC(val))
return (val);
val = find_env(addr, 0);
if ((val != FAILSE) && IS_FUNC(val))
return (val);
val = GET_CAR(addr);
if (IS_FUNC(val))
return (val);
else
return (0);
}
int macrop(int addr)
{
if (!CELLRANGE(addr))
return (0);
else if (!CELLRANGE(GET_CAR(addr)))
return (0);
else if (IS_MACRO(GET_CAR(addr)))
return (1);
else
return (0);
}
int genericp(int addr)
{
if (IS_GENERIC(GET_CAR(addr)))
return (1);
else
return (0);
}
int stringp(int x)
{
if (IS_STRING(x))
return (1);
else
return (0);
}
DEF_PREDICATE(CHARACTER, CHR)
int charp(int x)
{
if (IS_CHARACTER(x))
return (1);
else
return (0);
}
int vectorp(int x)
{
if (IS_VECTOR(x))
return (1);
else
return (0);
}
int arrayp(int x)
{
if (IS_ARRAY(x))
return (1);
else
return (0);
}
DEF_PREDICATE(STREAM, STREAM)
int streamp(int x)
{
if (IS_STREAM(x))
return (1);
else
return (0);
}
int string_input_stream_p(int x)
{
if (streamp(x) && GET_OPT(x) == EISL_INSTR)
return (1);
else
return (0);
}
int input_stream_p(int x)
{
if (streamp(x)
&& (GET_OPT(x) == EISL_INPUT ||
GET_OPT(x) == EISL_INOUT ||
GET_OPT(x) == EISL_INPUT_BIN ||
GET_OPT(x) == EISL_INOUT_BIN || GET_OPT(x) == EISL_INSTR))
return (1);
else
return (0);
}
int text_input_stream_p(int x)
{
if (streamp(x)
&& (GET_OPT(x) == EISL_INPUT ||
GET_OPT(x) == EISL_INOUT || GET_OPT(x) == EISL_INSTR))
return (1);
else
return (0);
}
int binary_input_stream_p(int x)
{
if (streamp(x)
&& (GET_OPT(x) == EISL_INPUT_BIN || GET_OPT(x) == EISL_INOUT_BIN))
return (1);
else
return (0);
}
int output_stream_p(int x)
{
if (streamp(x)
&& (GET_OPT(x) == EISL_OUTPUT ||
GET_OPT(x) == EISL_INOUT ||
GET_OPT(x) == EISL_OUTPUT_BIN ||
GET_OPT(x) == EISL_INOUT_BIN || GET_OPT(x) == EISL_OUTSTR))
return (1);
else
return (0);
}
int text_output_stream_p(int x)
{
if (streamp(x)
&& (GET_OPT(x) == EISL_OUTPUT ||
GET_OPT(x) == EISL_INOUT || GET_OPT(x) == EISL_OUTSTR))
return (1);
else
return (0);
}
int binary_output_stream_p(int x)
{
if (streamp(x)
&& (GET_OPT(x) == EISL_OUTPUT_BIN || GET_OPT(x) == EISL_INOUT_BIN))
return (1);
else
return (0);
}
int socketp(int x)
{
if (streamp(x) && GET_OPT(x) == EISL_SOCKET)
return (1);
else
return (0);
}
int class_symbol_p(int x)
{
if (IS_SYMBOL(x) && GET_OPT(x) == SYSTEM)
return (1);
else
return (0);
}
int classp(int x)
{
if (IS_CLASS(x))
return (1);
else
return (0);
}
int subclassp(int x, int y)
{
if (x == y)
return (0);
else if (y == cobject)
return (1);
else if (x == cobject)
return (0);
else
return (subclassp1(x, y));
}
int subclassp1(int x, int y)
{
if (nullp(x))
return (0);
else if (atomp(x)) {
if (x == y)
return (1);
else if (GET_OPT(x) == USER && y == cstandard_object)
return (1);
else if (GET_OPT(x) == USER && GET_OPT(y) == SYSTEM) {
x = cstandard_class;
return (subclassp1(x, y));
} else if (symbolp(x))
return (subclassp1(GET_AUX(x), y));
else if (GET_CAR(x) == NIL)
return (0);
else
return (subclassp1(GET_CAR(x), y));
} else {
if (subclassp1(car(x), y) || subclassp1(cdr(x), y))
return (1);
else
return (0);
}
}
int has_common_p(int ls)
{
if (length(ls) < 2)
return (0);
while (!nullp(cdr(ls))) {
if (has_common_p1(car(ls), cadr(ls)))
return (1);
else
ls = cdr(ls);
}
return (0);
}
int has_common_p1(int x, int y)
{
if (includep(GET_CAR(GET_AUX(x)), GET_CAR(GET_AUX(y))))
return (1);
else if (y != cobject && y != cstandard_class && subclassp(x, y))
return (1);
else if (x != cobject && x != cstandard_class && subclassp(y, x))
return (1);
else
return (0);
}
int includep(int x, int y)
{
while (!nullp(x)) {
if (member(car(x), y))
return (1);
else
x = cdr(x);
}
return (0);
}
int has_same_p(int ls)
{
while (!nullp(ls)) {
if (member(car(ls), cdr(ls)))
return (1);
else
ls = cdr(ls);
}
return (0);
}
int has_sys_class_p(int ls)
{
while (!nullp(ls)) {
if (GET_OPT(car(ls)) == SYSTEM)
return (1);
else
ls = cdr(ls);
}
return (0);
}
int not_exist_class_p(int ls)
{
while (!nullp(ls)) {
if (GET_AUX(car(ls)) == csymbol)
return (1);
else
ls = cdr(ls);
}
return (0);
}
int illegal_lambda_p(int ls)
{
if (!listp(ls) && !nullp(ls))
return (1);
if (nullp(ls))
return (0);
else if (car(ls) == T)
return (1);
else if (car(ls) == NIL)
return (1);
else if (eqp(car(ls), make_sym("*PI*")))
return (1);
else if (eqp(car(ls), make_sym("*MOST-POSITIVE-FLOAT*")))
return (1);
else if (eqp(car(ls), make_sym("*MOST-NEGATIVE-FLOAT*")))
return (1);
else if (eqp(car(ls), make_sym(":REST"))
&& member(make_sym(":REST"), cdr(ls)))
return (1);
else if (eqp(car(ls), make_sym("&REST"))
&& member(make_sym("&REST"), cdr(ls)))
return (1);
else if (eqp(car(ls), make_sym(":REST"))
&& member(make_sym("&REST"), cdr(ls)))
return (1);
else if (eqp(car(ls), make_sym("&REST"))
&& member(make_sym(":REST"), cdr(ls)))
return (1);
else if (symbolp(car(ls)) && !eqp(car(ls), make_sym(":REST"))
&& !eqp(car(ls), make_sym("&REST"))
&& (STRING_REF(car(ls), 0) == ':'
|| STRING_REF(car(ls), 0) == '&'))
return (1);
else
return (illegal_lambda_p(cdr(ls)));
}
int undef_parameter_p(int ls)
{
if (nullp(ls))
return (0);
else if (symbolp(car(ls)))
return (undef_parameter_p(cdr(ls)));
else if (listp(car(ls))) {
/* e.g. ((x undef)) undef is only symbol and it's class is (class ) */
if (symbolp(cadar(ls)) && GET_AUX(cadar(ls)) == csymbol)
return (1);
else
return (undef_parameter_p(cdr(ls)));
} else
return (1);
}
int unified_parameter_p(int lamlis, int ls)
{
if (nullp(lamlis) && nullp(ls))
return (1);
else if (nullp(lamlis) && !nullp(ls))
return (0);
else if (!nullp(lamlis) && nullp(ls))
return (0);
else if ((eqp(car(lamlis), make_sym(":REST"))
|| eqp(car(lamlis), make_sym("&REST")))
&& (eqp(car(ls), make_sym(":REST"))
|| eqp(car(ls), make_sym("&REST"))))
return (unified_parameter_p(cdr(lamlis), cdr(ls)));
else if (symbolp(car(lamlis)) && symbolp(car(ls)))
return (unified_parameter_p(cdr(lamlis), cdr(ls)));
else if (symbolp(car(lamlis))
&& (listp(car(ls) && length(car(ls) == 2))))
return (unified_parameter_p(cdr(lamlis), cdr(ls)));
else if ((listp(car(lamlis)) && length(car(lamlis)) == 2)
&& (listp(car(ls) && length(car(ls) == 2))))
return (unified_parameter_p(cdr(lamlis), cdr(ls)));
else
return (0);
/*
* check unification lambda-list of generic-function and
* method-parameter e.g. lambda-list=(x y :rest z) parameter= ((x
* )(y ) :rest (z 1)
return (1);
else if (eqp(car(ls), make_sym(":REST")) && length(cdr(ls)) > 1)
return (1);
else if (eqp(car(ls), make_sym("&REST"))
|| eqp(car(ls), make_sym(":REST")))
return (duplicate_list_p(cddr(ls)));
else
return (duplicate_list_p(cdr(ls)));
}
int symbol_list_p(int ls)
{
if (nullp(ls))
return (1);
else if (!symbolp(car(ls)))
return (0);
else if (eqp(car(ls), make_sym("&REST")) && !symbolp(cadr(ls)))
return (0);
else if (eqp(car(ls), make_sym(":REST")) && !symbolp(cadr(ls)))
return (0);
else
return (symbol_list_p(cdr(ls)));
}
int has_multiple_call_next_method_p(int x)
{
int count, ls;
count = 0;
ls = x;
while (!nullp(ls)) {
if (has_multiple_call_next_method_p1(car(ls)))
count++;
if (has_multiple_call_next_method_p2(car(ls)))
return (1);
ls = cdr(ls);
}
if (count >= 2)
return (1);
else
return (0);
}
int has_multiple_call_next_method_p1(int x)
{
if (nullp(x))
return (0);
else if (symbolp(x) && eqp(x, make_sym("CALL-NEXT-METHOD")))
return (1);
else if (atomp(x))
return (0);
else if (has_multiple_call_next_method_p1(car(x))
|| has_multiple_call_next_method_p1(cdr(x)))
return (1);
else
return (0);
}
/* e.g. (list (call-next-method) (call-next-method)) */
int has_multiple_call_next_method_p2(int x)
{
int count, ls;
count = 0;
ls = x;
while (!nullp(ls)) {
if (has_multiple_call_next_method_p1(car(ls)))
count++;
ls = cdr(ls);
}
if (count >= 2)
return (1);
else
return (0);
}
/* if function is writer or accesor generic function.
* slot gunctions have property,
* 1=reader, 2=writer, 3=accesor 4=boundp
*/
int slot_accesor_p(int x)
{
int prop;
prop = cdr(assoc(make_sym("SLOT"), GET_PROP(x)));
if (integerp(prop) && (get_int(prop) == 2 || get_int(prop) == 3))
return (1);
else
return (0);
}
/* --------------list operation--------------------- */
int car(int addr)
{
return (GET_CAR(addr));
}
int caar(int addr)
{
return (car(car(addr)));
}
int cdar(int addr)
{
return (cdr(car(addr)));
}
int cdr(int addr)
{
return (GET_CDR(addr));
}
int cadr(int addr)
{
return (car(cdr(addr)));
}
int cddr(int addr)
{
return (cdr(cdr(addr)));
}
int caddr(int addr)
{
return (car(cdr(cdr(addr))));
}
int cadar(int addr)
{
return (car(cdr(car(addr))));
}
int cdddr(int addr)
{
return (cdr(cdr(cdr(addr))));
}
int caddar(int addr)
{
return (car(cdr(cdr(car(addr)))));
}
int nth(int n, int addr)
{
while (n > 0) {
addr = cdr(addr);
n--;
}
return (car(addr));
}
int cons(int car, int cdr)
{
int addr;
addr = freshcell();
SET_TAG(addr, LIS);
SET_CAR(addr, car);
SET_CDR(addr, cdr);
SET_AUX(addr, ccons); /* cons class */
return (addr);
}
int tcons(int car, int cdr, int th)
{
int addr;
addr = tfreshcell(th);
SET_TAG(addr, LIS);
SET_CAR(addr, car);
SET_CDR(addr, cdr);
SET_AUX(addr, ccons); /* cons class */
return (addr);
}
int length(int addr)
{
int len = 0;
while (!nullp(addr) && !atomp(addr)) {
len++;
addr = cdr(addr);
}
return (len);
}
int list(int arglist)
{
if (nullp(arglist))
return (NIL);
else
return (cons(car(arglist), list(cdr(arglist))));
}
int assoc(int x, int y)
{
if (nullp(y))
return (0);
else if (eqlp(x, caar(y)))
return (car(y));
else
return (assoc(x, cdr(y)));
}
int assq(int x, int y)
{
if (nullp(y))
return (FAILSE);
else if (eqp(x, caar(y)))
return (car(y));
else
return (assq(x, cdr(y)));
}
int assoc_list_p(int ls)
{
while (!nullp(ls)) {
if (!listp(car(ls)))
return (0);
else
ls = cdr(ls);
}
return (1);
}
int member(int x, int y)
{
if (nullp(y))
return (NIL);
else if (equalp(x, car(y)))
return (y);
else
return (member(x, cdr(y)));
}
int member1(int x, int y, int z)
{
if (nullp(y))
return (NIL);
else if (apply(z, list2(x, car(y)), 0) != NIL)
return (y);
else
return (member1(x, cdr(y), z));
}
/* extension */
int list1(int x)
{
return (cons(x, NIL));
}
int list2(int x, int y)
{
return (cons(x, cons(y, NIL)));
}
int list3(int x, int y, int z)
{
return (cons(x, cons(y, cons(z, NIL))));
}
int list4(int x1, int x2, int x3, int x4)
{
return (cons(x1, cons(x2, cons(x3, cons(x4, NIL)))));
}
int list6(int x1, int x2, int x3, int x4, int x5, int x6)
{
return (cons
(x1, cons(x2, cons(x3, cons(x4, cons(x5, cons(x6, NIL)))))));
}
int list8(int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8)
{
return (cons(x1, cons(x2, cons(x3, cons(x4, cons(x5,
cons(x6,
cons(x7,
cons(x8,
NIL)))))))));
}
int
list10(int x1, int x2, int x3, int x4, int x5,
int x6, int x7, int x8, int x9, int x10)
{
return (cons(x1, cons(x2, cons(x3, cons(x4, cons(x5,
cons(x6,
cons(x7,
cons(x8,
cons
(x9,
cons
(x10,
NIL)))))))))));
}
int
list11(int x1, int x2, int x3, int x4, int x5,
int x6, int x7, int x8, int x9, int x10, int x11)
{
return (cons(x1, cons(x2, cons(x3, cons(x4, cons(x5,
cons(x6,
cons(x7,
cons(x8,
cons
(x9,
cons
(x10,
cons
(x11,
NIL))))))))))));
}
int reverse(int x)
{
int res;
res = NIL;
while (!nullp(x) && !atomp(x)) {
res = cons(car(x), res);
x = cdr(x);
}
return (res);
}
int last(int x)
{
return (car(reverse(x)));
}
int append(int x, int y)
{
if (nullp(x))
return (y);
else
return (cons(car(x), append(cdr(x), y)));
}
int instancep(int x)
{
if (GET_TAG(x) == INSTANCE)
return (T);
else
return (NIL);
}
/*
* defclass eval :initform val.
* when create make new instance, copy instance of val.
* e.g.
(defclass () ((slot-inner :accessor slot-inner :initarg slot-inner)))
(defclass () ((slot-outer :reader slot-outer :initform (create (class ) 'slot-inner 'hoge))))
(let ((outer-1 (create (class )))
(outer-2 (create (class ))))
(format (standard-output) "~S~%" (slot-inner (slot-outer outer-1)))
;; => HOGE
(format (standard-output) "~S~%" (slot-inner (slot-outer outer-2)))
;; => HOGE
(setf (slot-inner (slot-outer outer-1)) 'FUGA)
(format (standard-output) "~S~%" (slot-inner (slot-outer outer-1)))
;; => FUGA
(format (standard-output) "~S~%" (slot-inner (slot-outer outer-2)))
;; => Expected HOGE, but FUGA
)
*/
int copy_instance(int x)
{
int addr, initls, cl;
addr = freshcell();
SET_TAG(addr, INSTANCE);
SET_CAR(addr, GET_CAR(x)); /* super class */
SET_CDR(addr, copy(GET_CDR(x))); /* slot vars with super class */
SET_AUX(addr, GET_AUX(x)); /* class of instance */
SET_OPT(addr, GET_OPT(x)); /* initls */
initls = GET_OPT(addr);
cl = GET_AUX(addr);
while (!nullp(initls)) {
set_val(cdr(assq(car(initls), GET_AUX(cl))), cadr(initls),
GET_CDR(addr));
initls = cddr(initls);
}
return (addr);
}
int copy(int x)
{
if (nullp(x))
return (NIL);
else if (x == UNDEF)
return (make_dummy());
else if (integerp(x))
return (make_int(GET_INT(x)));
else if (floatp(x))
return (make_flt(GET_FLT(x)));
else if (charp(x))
return (make_char(GET_NAME(x)));
else if (stringp(x))
return (make_str(GET_NAME(x)));
else if (instancep(x))
return (copy_instance(x));
else if (listp(x))
return (cons(copy(car(x)), copy(cdr(x))));
else
return (x);
}
int listref(int lis, int n)
{
while (!(nullp(lis))) {
if (n == 0) {
return (car(lis));
} else {
lis = cdr(lis);
n--;
}
}
return (NIL);
}
int listref1(int lis, int n)
{
while (!(nullp(lis))) {
if (n == 0) {
return (lis);
} else {
lis = cdr(lis);
n--;
}
}
return (NIL);
}
int listcopy(int lis)
{
if (nullp(lis))
return (NIL);
else if (!listp(lis))
return (lis);
else
return (cons(car(lis), listcopy(cdr(lis))));
}
int remove_list(int x, int y)
{
if (nullp(x))
return (NIL);
else if (member(car(x), y))
return (cdr(x));
else
return (cons(car(x), remove_list(cdr(x), y)));
}
void vector_set(int v, int n, int obj)
{
SET_VEC_ELT(v, n, obj);
}
int vector_ref(int v, int n)
{
return (GET_VEC_ELT(v, n));
}
int vector_length(int v)
{
return (GET_CDR(v));
}
int array_length(int obj)
{
return (GET_CDR(obj));
}
/* n=0 ex ((1 2) 3 (4 5)) -> (1 2 3 4 5) */
int flatten(int n, int ls)
{
if (nullp(ls))
return (ls);
else if (n <= 1)
return (ls);
else if (atomp(car(ls)))
return (cons(car(ls), flatten(n, cdr(ls))));
else
return (append(flatten(n - 1, car(ls)), flatten(n, cdr(ls))));
}
/* e.g. (1 2 3 4) -> ((1 2)(3 4)) */
int structured(int ls, int st)
{
return (structured1(ls, reverse(st)));
}
int structured1(int ls, int st)
{
if (nullp(cdr(st)))
return (ls);
else
return (structured1(structured2(ls, GET_INT(car(st))), cdr(st)));
}
int structured2(int ls, int n)
{
if (nullp(ls))
return (NIL);
else
return (cons(list_take(ls, n), structured2(list_drop(ls, n), n)));
}
int list_take(int ls, int n)
{
if (n == 0)
return (NIL);
else
return (cons(car(ls), list_take(cdr(ls), n - 1)));
}
int list_drop(int ls, int n)
{
if (n == 0)
return (ls);
else
return (list_drop(cdr(ls), n - 1));
}
/* generate array from list. e.g. #na(ls) ls=((1 2)(3 4)) */
int array(int n, int ls)
{
int dim, res, ls1, i;
dim = array_dim(n, ls);
if (n == 0) {
res = make_arr(dim, ls);
return (res);
} else if (n == 1)
res = make_vec(GET_INT(car(dim)), UNDEF);
else
res = make_arr(dim, UNDEF);
ls1 = flatten(n, ls);
i = 0;
while (!nullp(ls1)) {
SET_VEC_ELT(res, i, car(ls1));
i++;
ls1 = cdr(ls1);
}
SET_PROP(res, ls); /* for FAST compiler regist original list */
return (res);
}
int vector_to_list(int x)
{
int res, i;
i = vector_length(x) - 1;
res = NIL;
while (i >= 0) {
res = cons(vector_ref(x, i), res);
i--;
}
return (res);
}
static inline void SET_CHAR(int addr, char x)
{
REQUIRE(CELLRANGE(addr) && GET_TAG(addr) == CHR);
heap[addr].name[0] = x;
}
int string_to_vector(int x)
{
int res, len, i, ref;
char c;
len = strlen(GET_NAME(x));
res = make_vec(len, UNDEF);
ref = 0;
i = 0;
c = STRING_REF(x, i++);
while (c != NUL) {
int chr;
chr = make_char("?");
SET_CHAR(chr, c);
vector_set(res, ref++, chr);
c = STRING_REF(x, i++);
}
return (res);
}
int string_to_list(int x)
{
int i, len, res;
res = NIL;
len = string_length(x);
for (i = 0; i < len; i++) {
int chr;
chr = string_ref(x, i);
res = cons(chr, res);
}
return (reverse(res));
}
int substr(int x, int s, int e)
{
int i, j, pos, c;
char *str;
str = ALLOC(((e - s) + 1) * 6);
/* for unicode allocate 6 byte for 1 char skip to start position */
i = 0;
pos = 0;
while (i < s) {
c = STRING_REF(x, pos);
if (isUni1(c)) {
pos++;
i++;
} else if (isUni2(c)) {
pos = pos + 2;
i++;
} else if (isUni3(c)) {
pos = pos + 3;
i++;
} else if (isUni4(c)) {
pos = pos + 4;
i++;
} else if (isUni5(c)) {
pos = pos + 5;
i++;
} else if (isUni6(c)) {
pos = pos + 6;
i++;
}
}
j = 0;
while (i < e) {
c = STRING_REF(x, pos);
if (isUni1(c)) {
str[j++] = STRING_REF(x, pos++);
i++;
} else if (isUni2(c)) {
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
i++;
} else if (isUni3(c)) {
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
i++;
} else if (isUni4(c)) {
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
i++;
} else if (isUni5(c)) {
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
i++;
} else if (isUni6(c)) {
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
str[j++] = STRING_REF(x, pos++);
i++;
}
}
str[j] = NUL;
int res = make_str(str);
FREE(str);
return res;
}
int string_length(int addr)
{
char str[STRSIZE], c;
int pos, n;
strcpy(str, GET_NAME(addr));
pos = 0;
n = 0;
c = str[pos];
while (c != NUL) {
if (isUni2(c)) {
n++;
pos = pos + 2;
} else if (isUni3(c)) {
n++;
pos = pos + 3;
} else if (isUni4(c)) {
n++;
pos = pos + 4;
} else if (isUni5(c)) {
n++;
pos = pos + 5;
} else if (isUni6(c)) {
n++;
pos = pos + 6;
} else {
n++;
pos++;
}
c = str[pos];
}
return (n);
}
int string_ref(int x, int y)
{
char str[CHARSIZE];
int pos, y1;
pos = 0;
y1 = 0;
while (STRING_REF(x, pos) != NUL) {
if (GET_INT(y) == y1) {
if (isUni2(STRING_REF(x, pos))) {
str[0] = STRING_REF(x, pos);
str[1] = STRING_REF(x, pos + 1);
str[2] = NUL;
} else if (isUni3(STRING_REF(x, pos))) {
str[0] = STRING_REF(x, pos);
str[1] = STRING_REF(x, pos + 1);
str[2] = STRING_REF(x, pos + 2);
str[3] = NUL;
} else if (isUni4(STRING_REF(x, pos))) {
str[0] = STRING_REF(x, pos);
str[1] = STRING_REF(x, pos + 1);
str[2] = STRING_REF(x, pos + 2);
str[3] = STRING_REF(x, pos + 3);
str[4] = NUL;
} else if (isUni5(STRING_REF(x, pos))) {
str[0] = STRING_REF(x, pos);
str[1] = STRING_REF(x, pos + 1);
str[2] = STRING_REF(x, pos + 2);
str[3] = STRING_REF(x, pos + 3);
str[4] = STRING_REF(x, pos + 4);
str[5] = NUL;
} else if (isUni6(STRING_REF(x, pos))) {
str[0] = STRING_REF(x, pos);
str[1] = STRING_REF(x, pos + 1);
str[2] = STRING_REF(x, pos + 2);
str[3] = STRING_REF(x, pos + 3);
str[4] = STRING_REF(x, pos + 4);
str[5] = STRING_REF(x, pos + 5);
str[6] = NUL;
} else {
str[0] = STRING_REF(x, pos);
str[1] = NUL;
}
return (make_char(str));
}
if (isUni2(STRING_REF(x, pos))) {
pos = pos + 2;
y1++;
} else if (isUni3(STRING_REF(x, pos))) {
pos = pos + 3;
y1++;
} else if (isUni4(STRING_REF(x, pos))) {
pos = pos + 4;
y1++;
} else if (isUni5(STRING_REF(x, pos))) {
pos = pos + 5;
y1++;
} else if (isUni6(STRING_REF(x, pos))) {
pos = pos + 6;
y1++;
} else {
pos = pos + 1;
y1++;
}
}
return (NIL);
}
/*
* string_set() It is assumed that the characters to be replaced and the
* characters to be replaced are the same size. It's incomplete, but it
* shouldn't be a problem in practice. If you try to do it completely, it
* will be complicated.
*/
int string_set(int x, int y, int z)
{
char str[STRSIZE];
int pos, y1;
pos = 0;
y1 = 0;
strcpy(str, GET_NAME(z));
while (STRING_REF(x, pos) && pos < STRSIZE) {
if (GET_INT(y) == y1) {
if (isUni2(str[0])) {
STRING_SET(x, pos, str[0]);
STRING_SET(x, pos + 1, str[1]);
} else if (isUni3(str[0])) {
STRING_SET(x, pos, str[0]);
STRING_SET(x, pos + 1, str[1]);
STRING_SET(x, pos + 2, str[2]);
} else if (isUni4(str[0])) {
STRING_SET(x, pos, str[0]);
STRING_SET(x, pos + 1, str[1]);
STRING_SET(x, pos + 2, str[2]);
STRING_SET(x, pos + 3, str[3]);
} else if (isUni5(str[0])) {
STRING_SET(x, pos, str[0]);
STRING_SET(x, pos + 1, str[1]);
STRING_SET(x, pos + 2, str[2]);
STRING_SET(x, pos + 3, str[3]);
STRING_SET(x, pos + 4, str[4]);
} else if (isUni6(str[0])) {
STRING_SET(x, pos, str[0]);
STRING_SET(x, pos + 1, str[1]);
STRING_SET(x, pos + 2, str[2]);
STRING_SET(x, pos + 3, str[3]);
STRING_SET(x, pos + 4, str[4]);
STRING_SET(x, pos + 5, str[5]);
} else {
STRING_SET(x, pos, str[0]);
}
return (make_char(str));
}
if (isUni2(STRING_REF(x, pos))) {
pos = pos + 2;
y1++;
} else if (isUni3(STRING_REF(x, pos))) {
pos = pos + 3;
y1++;
} else if (isUni4(STRING_REF(x, pos))) {
pos = pos + 4;
y1++;
} else if (isUni5(STRING_REF(x, pos))) {
pos = pos + 5;
y1++;
} else if (isUni6(STRING_REF(x, pos))) {
pos = pos + 6;
y1++;
} else {
pos++;
y1++;
}
}
return (NIL);
}
int sublis(int x, int s, int e)
{
int i, res;
res = NIL;
i = 0;
while (!nullp(x)) {
if (i >= s && i < e)
res = cons(copy(car(x)), res);
i++;
x = cdr(x);
}
return (reverse(res));
}
int subvec(int x, int s, int e)
{
int i, j, res;
res = make_vec(e - s, UNDEF);
j = 0;
for (i = s; i < e; i++) {
SET_VEC_ELT(res, j, copy(GET_VEC_ELT(x, i)));
j++;
}
return (res);
}
/*
* compare priority of argument list of method
* if x is higher than y, return 1.
*/
int high_priority_p(int x, int y)
{
int args1, args2, argx, argy, classx, classy;
if (GET_OPT(x) > GET_OPT(y)) // :around ... etc
return (0);
else if (GET_OPT(x) < GET_OPT(y))
return (1);
else if (GET_OPT(x) == AFTER && GET_OPT(y) == AFTER) {
/*
* case :after this is reverse case primary when compiling,
* compiler chenge order. use (change-priority-for-compiler t)
*/
args1 = car(GET_CAR(x)); /* lambda-list */
args2 = car(GET_CAR(y));
while (!nullp(args1)) {
argx = car(args1);
argy = car(args2);
if (atomp(argy)) { /* case of no class information */
args1 = cdr(args1);
args2 = cdr(args2);
} else {
if (atomp(argx))
return (1);
classx = GET_AUX(cadr(argx));
classy = GET_AUX(cadr(argy));
if (subclassp(classy, classx))
return (1);
args1 = cdr(args1);
args2 = cdr(args2);
}
}
return (0);
} else {
args1 = car(GET_CAR(x)); /* lambda-list */
args2 = car(GET_CAR(y));
while (!nullp(args1)) {
argx = car(args1);
argy = car(args2);
if (atomp(argx)) { /* case of no class information */
args1 = cdr(args1);
args2 = cdr(args2);
} else {
if (atomp(argy))
return (1);
classx = GET_AUX(cadr(argx));
classy = GET_AUX(cadr(argy));
if (subclassp(classx, classy))
return (1);
args1 = cdr(args1);
args2 = cdr(args2);
}
}
return (0);
}
}
void insert_method(int x, int func)
{
int methods, res;
methods = GET_CDR(func);
if (nullp(methods)) {
SET_CDR(func, list1(x));
return;
}
res = NIL;
while (!nullp(methods)) {
if (high_priority_p(car(methods), x)) {
res = cons(car(methods), res);
methods = cdr(methods);
} else
break;
}
res = append(reverse(cons(x, res)), methods);
SET_CDR(func, res);
return;
}
void resort_method(int func)
{
int methods, res;
methods = GET_CDR(func);
if (nullp(methods))
return;
res = cons(car(methods), NIL);
methods = cdr(methods);
while (!nullp(methods)) {
int temp, x;
x = car(methods);
temp = NIL;
bool high_priority_found = false;
while (!nullp(res)) {
if (high_priority_p(x, car(res))) {
res = append(reverse(temp), cons(x, res));
high_priority_found = true;
break;
} else {
temp = cons(car(res), temp);
res = cdr(res);
}
}
if (!high_priority_found) {
res = reverse(cons(x, temp));
}
methods = cdr(methods);
}
SET_CDR(func, res);
}
void redef_generic(void)
{
int ls;
ls = generic_list;
while (!nullp(ls)) {
resort_method(GET_CAR(car(ls)));
ls = cdr(ls);
}
redef_flag = false;
return;
}
int method_qualifier_p(int x)
{
if (eqp(x, make_sym(":BEFORE")) ||
eqp(x, make_sym(":AFTER")) || eqp(x, make_sym(":AROUND")))
return (1);
else
return (0);
}
/*
* ----------unicode------------------
* transform from UTF-8 to unicode
*/
int utf8_to_ucs4(char *p)
{
int x, x1, x2, x3, res;
unsigned char uc;
uc = (unsigned char) *p;
if (uc <= 0x7f) {
x = (int) uc;
return (x);
} else if (uc >= 0xc0 && uc <= 0xdf) {
x = (int) (UTF2MSK1 & uc);
x = x << 6;
p++;
uc = (unsigned char) *p;
x1 = (int) (UTFOMSKO & uc);
res = x | x1;
return (res);
} else if (uc >= 0xe0 && uc <= 0xef) {
x = (int) (UTF3MSK1 & uc);
x = x << 12;
p++;
uc = (unsigned char) *p;
x1 = (int) (UTFOMSKO & uc);
x1 = x1 << 6;
p++;
uc = (unsigned char) *p;
x2 = (int) (UTFOMSKO & uc);
res = x | x1 | x2;
return (res);
} else if (uc >= 0xf0 && uc <= 0xf7) {
x = (int) (UTF4MSK1 & uc);
x = x << 18;
p++;
uc = (unsigned char) *p;
x1 = (int) (UTFOMSKO & uc);
x1 = x1 << 12;
p++;
uc = (unsigned char) *p;
x2 = (int) (UTFOMSKO & uc);
x2 = x2 << 6;
p++;
uc = (unsigned char) *p;
x3 = (int) (UTFOMSKO & uc);
res = x | x1 | x2 | x3;
return (res);
} else
return (-1);
}
/* transform from Unicode to UTF-8 */
void ucs4_to_utf8(int n, char *p)
{
int w, x, y, z;
if (n <= 0x7f) {
*p = (char) n;
} else if (n <= 0x07ff) {
x = UNI2MSK1 & n;
x = x >> 6;
x = UNI2ADD1 | x;
y = UNI2MSK2 & n;
y = UNIOADDO | y;
*p = (char) x;
p++;
*p = (char) y;
} else if (n <= 0xffff) {
x = UNI3MSK1 & n;
x = x >> 12;
x = UNI3ADD1 | x;
y = UNI3MSK2 & n;
y = y >> 6;
y = UNIOADDO | y;
z = UNI3MSK3 & n;
z = UNIOADDO | z;
*p = (char) x;
p++;
*p = (char) y;
p++;
*p = (char) z;
} else if (n < 0x1fffff) {
w = UNI4MSK1 & n;
w = w >> 18;
w = UNI4ADD1 | w;
x = UNI4MSK2 & n;
x = x >> 12;
x = UNIOADDO | x;
y = UNI4MSK3 & n;
y = y >> 6;
y = UNIOADDO | y;
z = UNI4MSK4 & n;
z = UNIOADDO | z;
*p = (char) w;
p++;
*p = (char) x;
p++;
*p = (char) y;
p++;
*p = (char) z;
} else {
error(OUT_OF_RANGE, "Unicode->UTF-8", NIL, 0);
}
p++;
*p = NUL;
}
eisl-5.55/documents/ 0000775 0000000 0000000 00000000000 15066676224 0014423 5 ustar 00root root 0000000 0000000 eisl-5.55/documents/ATFIRST.md 0000664 0000000 0000000 00000003524 15066676224 0016065 0 ustar 00root root 0000000 0000000 # At first
Please read this first.
The document folder contains various documents. Mainly explains how to use the library.
# Common
Please do as follows:
```
sudo make install
```
Some libraries need to be compiled. They use a C wrapper and will not work unless compiled.
Please do as follows:
```
make lisp
```
By default, the installation is kept light by compiling without the -flto option. To enable faster performance with -flto, please recompile as follows:
```
sudo make clean
sudo make install USE_FLTO=1
```
When using gpio on Raspberry Pi: please install gpio and compile with the following options.
```
sudo apt update
sudo apt install libgpiod-dev
sudo make install USE_GPIO=1
```
When using wiringPi on Raspberry Pi: please install wiringPi and compile with the following options.
```
sudo make install USE_WIRINGPI=1
```
# Documents
## Library
# Development
# Extension
# Specification
# Other
eisl-5.55/documents/BENCH.md 0000664 0000000 0000000 00000004661 15066676224 0015573 0 ustar 00root root 0000000 0000000 # Benchmark
I applied the
[benchmark test](http://christian.jullien.free.fr/benchmarks.html)
written by
[Mr. Jullien](http://www.eligis.com)
to Easy-ISLisp.
See the "bench" directory.
# Hardware
Intel(R) Core(TM) i5-6500 CPU @ 3.20GHz
# EISL Compiler
Before running, please compile with cpbench.lsp.
Here are some results for WSL Ubuntu:
```
$ eisl -s bench/runbench.lsp
Test 01: Fib -> ok, time = 00000s.
Test 02: Tak -> ok, time = 00000s.
Test 03: Stak -> 12, time = 00000s.
Test 04: Ctak -> ok, time = 00000s.
Test 05: Takl -> ok, time = 00000s.
Test 06: Takr -> ok, time = 00000s.
Test 07: Boyer -> T, time = 0.046875s.
Test 08: Browse -> ok, time = 0.078125s.
Test 09: Destru -> ok, time = 00000s.
Test 10: Travini -> ok, time = 0.015625s.
Test 11: Travrun -> ok, time = 0.28125s.
Test 12: Deriv -> ok, time = 00000s.
Test 13: Dderiv -> ok, time = 00000s.
Test 14: Divit -> ok, time = 00000s.
Test 15: Divrec -> ok, time = 00000s.
Test 16: FFT -> ok, time = 0.03125s.
Test 17: Puzzle -> ok, time = 0.0625s.
Test 18: Triang -> ok, time = 1.34375s.
Test 19: Fprint -> ok, time = 00000s.
Test 20: Fread -> ok, time = 00000s.
Test 21: Tprint -> ok, time = 00000s.
Test 22: Frpoly -> ok, time = 0.00625s.
Total 1.90625s.
```
# OpenLisp
```
;; OpenLisp v11.1.0 (Build: 6652) by C. Jullien [Oct 30 2020 - 13:48:51]
;; Copyright (c) Eligis - 1988-2020.
;; System 'win64' (64bit, 6 CPU) on 'DESKTOP-0D0L6O5', ASCII.
;; Reading startup ..
;; God thank you, OpenLisp is back again!
? (load "bench/runbench.lsp")
Test 01: Fib -> ok, time = 0.001s.
Test 02: Tak -> ok, time = 0.003s.
Test 03: Stak -> ok, time = 0.015s.
Test 04: Ctak -> ok, time = 0.066s.
Test 05: Takl -> ok, time = 0.006s.
Test 06: Takr -> ok, time = 0.004s.
Test 07: Boyer -> ok, time = 0.048s.
Test 08: Browse -> ok, time = 0.055s.
Test 09: Destru -> ok, time = 0.010s.
Test 10: Travini -> ok, time = 0.050s.
Test 11: Travrun -> ok, time = 0.245s.
Test 12: Deriv -> ok, time = 0.010s.
Test 13: Dderiv -> ok, time = 0.013s.
Test 14: Divit -> ok, time = 0.005s.
Test 15: Divrec -> ok, time = 0.009s.
Test 16: FFT -> ok, time = 0.045s.
Test 17: Puzzle -> ok, time = 0.056s.
Test 18: Triang -> ok, time = 0.744s.
Test 19: Fprint -> ok, time = 0.005s.
Test 20: Fread -> ok, time = 0.001s.
Test 21: Tprint -> ok, time = 0.000s.
Test 22: Frpoly -> ok, time = 0.096s.
Total 1.487s.
;; elapsed time = 1.6486s, (8 gc).
= t
?
```
eisl-5.55/documents/BIT.md 0000664 0000000 0000000 00000002604 15066676224 0015365 0 ustar 00root root 0000000 0000000 # Bit
bitwise library
# Usage
(import "bit")
# functions
### logand
logand returns the bitwise AND of the two arguments.
```
> (logand #b0101 #b0011)
1
```
### logior
logior returns the bitwise OR for the two arguments.
```
> (logior #b0101 #b0011)
7
```
### logxor
logxor returns the bit-by-bit exclusive OR for the two arguments.
```
> (logxor #b0101 #b0011)
6
```
### lognot
lognot returns a bit-by-bit logical negation of the argument.
```
> (lognot 0)
-1 ; #b1111 .... 1111
> (logand 0 -1)
0
> (lognot 1)
-2 ; #b1111 .... 1110
> (logand 1 -2)
0
```
### logtest
logtest returns NIL if the result of logand is 0, T otherwise.
```
> (logtest 3 1)
T
> (logand 3 1)
1
> (logtest 3 4)
NIL
> (logand 3 4)
0
```
### logbitp
logbitp returns T if the bit of the integer at the position of the subscript index is 1.
Conversely, if it is 0, NIL is returned. Bit positions are counted from 0, as in arrays.
```
> (logbitp 0 #b0101)
T
> (logbitp 1 #b0101)
NIL
```
### logcount
logcount counts and returns 1 bit if integer is a positive value.
If it is a negative value, it counts and returns 0 bits.
```
> (logcount 13)
3 ; #b...0001101
> (logcount -13)
2 ; #b...1110011
```
### ash
ash shifts integer to the left by count bits.
The low-order bit is inserted with 0. If count is negative, it shifts count bits to the right.
```
> (ash 1 8)
256
> (ash -1 8)
-256
> (ash 256 -8)
1
``` eisl-5.55/documents/CHAITIN.md 0000664 0000000 0000000 00000007664 15066676224 0016041 0 ustar 00root root 0000000 0000000 # Chaitin's omega
The eval function is extended to test the stopping probability (Ω) of Chitin' theory.
see The LIMITS of MATHEMATICS by Gregory J. Chaitin.
# extended eval
(try limit-time S-expression binary-list :rest switch)
try function converts binary-list to ascii code character and make string-input-stream.
and evaluate S-expression in limit-time.
### limit-time
limit-time(integer) micro seconds
or 'no-time-limit symbol
If symbol no-time-limit is geven to the first argument, the S-expression second argument is evaluated with no time limitation.
If an integer is given to the first argument, the S-expression of the second argument is evaluated with that time as the limit.
If the calculation finishes within the time
Returns a list of the following three values:
(success value argument-of-calculation-process)
If the calculation did not finish within the time
Returns a list of the following three values:
(false out-of-time argument-of-calculation-process)
If the calculation occures error
Returns a list of the following three values:
(false out-of-data argument-of-calculation-process)
### S-expression
e.g. (eval (read-exp))
read-exp function is for try function. It read stream that created by binary-list.
### binary-list
8 bits ascii code.
e.g. 1 -> (0 0 1 1 0 0 0 1)(49(10))
ommit control code(0~31) and non ascii code(128-255)
### switch
out-of-time print string when out-of-time
out-of-data print string when out-of-data
success print string when success
# sample code
see example/chaitin.lsp
```
#|
limits of mathematics G.J.chaitin
H(x,y) <= H(x)+H(y)+c
in H(x) x means sexp.
H(x) means bit size of minimum UTM that calculate x.
H(y) means bit size of minimum UTM that calculate y.
φc x* y*
x* means minimum size program of x
y* means minimum size program of y
φc is prefix for constant c
(cons (eval (read-exp)) (cons (eval (read-exp)) nil) -> it make pair of x and y.
|#
(import "test")
;;; UTM universal turing machine
(defun U (p)
(try 'no-time-limit
'(eval (read-exp))
p))
;;; make binary list of s-expression
;;; add newline to sexp
(defun bits (s)
(let ((stream (create-string-output-stream))
(str nil))
(format stream "~A~%" s)
(setq str (get-output-stream-string stream))
(for ((i 0 (+ i 1))
(limit (length str))
(bin nil (append bin (char-to-bin (elt str i)))))
((>= i limit) bin))))
;;; make list of binary. ascii code.
(defun int-to-bin (n m)
(reverse (int-to-bin1 n m)))
(defun int-to-bin1 (n m)
(cond ((= m 0) nil)
((< n 2) (cons n (int-to-bin1 0 (- m 1))))
(t (cons (mod n 2) (int-to-bin1 (div n 2) (- m 1))))))
;;; make binary list of charactor c
(defun char-to-bin (c)
(int-to-bin (convert c ) 8))
;;; size of s-exp in binary
(defun size (s)
(length (bits s)))
;;; loop function
;;; eval can't calculate foo function.
(defun foo ()
(foo))
;;; count halt of s-exp(binary generated by n-bits)
(defun count-halt (time prefix bit-left)
(if (= bit-left 0)
(check time prefix)
(+ (count-halt time (cons 0 prefix) (- bit-left 1))
(count-halt time (cons 1 prefix) (- bit-left 1)))))
(defun check (time prefix)
;(print prefix)
(if (eq 'success (car (try time '(eval (read-exp)) prefix)))
1
0))
;;; test
($test (size '(+ 1 2)) 64)
($test (size '(cons (eval (read-exp)) (cons (eval (read-exp)) nil))) 432)
($test (bits '(+ 1 2))
(0 0 1 0 1 0 0 0 0 0 1 0 1 0 1 1 0 0 1 0 0 0 0 0 0 0 1 1 0 0 0 1 0 0 1 0 0 0 0 0 0 0 1 1 0 0 1 0 0 0 1 0 1 0 0 1 0 0 0 0 1 0 1 0))
($test (u (bits '(+ 1 2))) 3)
($test (u (bits '(+ g 2))) failse)
($test (elt (try 100 '(eval (read-exp)) (bits '(foo))) 1) out-of-time)
($test (car (try 100 '(eval (read-exp)) (bits '(+ 1 2)))) success)
($test (elt (try 100 '(eval (read-exp)) (bits '(+ h 2))) 1) out-of-data)
($test (elt (try 100 '(eval (read-exp)) '(1 1 0 0 0 0 0 0)) 1) out-of-data)
```
eisl-5.55/documents/CLUSTER.md 0000664 0000000 0000000 00000004435 15066676224 0016074 0 ustar 00root root 0000000 0000000 # Cluster
By using the distributed parallel features of N-Prolog, you can use a Raspberry Pi cluster machine as a parallel Prolog machine. Below is a memo for that.
Running boot.sh at Boot on Raspberry Pi (Network-Ready)
This document explains how to automatically run your boot.sh script at boot time on a Raspberry Pi, ensuring the network is fully up before execution.
Install
1. Prepare the boot.sh Script Place your script in /home/username/nprolog/boot.sh with the following content:
sudo nano /home/username/eisl/boot.sh
```
#!/bin/bash
# Change directory to 'Easy-ISLisp'.
# If this fails (e.g., directory does not exist), exit immediately with status 1.
cd /home/username/eisl || exit 1
# Run the 'eisl' program with the '-n' option.
./eisl -n
```
Make sure the script has execute permission:
```
sudo chmod +x /home/username/eisl/boot.sh
```
2. Create a systemd Service for Network-Ready Boot Execution
Create the systemd service file /etc/systemd/system/eisl.service
sudo nano /etc/systemd/system/eisl.service
```
[Unit]
Description=Run Easy-ISLisp at boot after network is ready
After=network-online.target
Wants=network-online.target
[Service]
ExecStart=/home/username/eisl/boot.sh
WorkingDirectory=/home/username
User=usename
Restart=on-failure
[Install]
WantedBy=multi-user.target
```
```
sudo systemctl enable eisl.service
```
Key points:
- After=network-online.target ensures the script runs after the network is up.
- Wants=network-online.target requests the network to be brought up before starting
# Update child
When upgrading the child machine, please follow the procedure below.
```
sudo systemctl1 stop eisl.service
cd eisl
git pull
sudo make install
```
and reboot PIs
# systemctl
Be sure to run enable; without doing this, automatic startup will not work. stop is used for temporarily stopping the service, for example when upgrading the child machine. The stop state will be cleared upon reboot. status can be used to check the situation when automatic startup is not working properly.
```
sudo systemctl enable eisl.service
sudo systemctl stop eisl.service
sudo systemctl status eisl.service
```
# Troubleshooting
It may take some time for a Raspberry Pi to become fully ready after powering on. Waiting about one minute before connecting with dp-create helps ensure stability. eisl-5.55/documents/COMBINATION.md 0000664 0000000 0000000 00000007216 15066676224 0016515 0 ustar 00root root 0000000 0000000 # Combination
Combination library.
This library was written by M. Hiroi.
# Acknowledgement
Thanks to Mr. Hiroi.
# Usage
```lisp
(import "combination")
```
# Specification
- selects xs => list
Select element, store selected element in CAR, store remaining elements in CDR, store it in list and return
- permutation fn n xs => nil
Generate a permutation that selects n elements from the list xs
- permutations n xs => list
Generate a permutation that selects n elements from the list xs
- permutation-with-repetition fn n xs => nil
Generate a permutations with n elements from the list xs
- permutations-with-repetition n xs => list
Generate a permutations with n elements from the list xs
- combination-number n r
Find the number of combinations nCr
- combination fn n xs => nil
Generate a combination that selects n elements from the list xs
- combinations n xs => list
Generate a combination that selects n elements from the list xs
- combination-with-repetition fn n xs => nil
Generate duplicate combinations that select n elements from the list xs
- combinations-with-repetition n xs => list
Generate duplicate combinations that select n elements from the list xs
# Test cases
```lisp
(test (selects '(1 2 3)) ((1 2 3) (2 1 3) (3 1 2)))
(test (selects '(a b c d)) ((A B C D) (B A C D) (C A B D) (D A B C)))
(test (permutations 3 '(1 2 3)) ((1 2 3) (1 3 2) (2 1 3) (2 3 1) (3 1 2) (3 2 1)))
(test (permutations 3 '(a b c d))
((A B C) (A B D) (A C B) (A C D) (A D B) (A D C) (B A C) (B A D)
(B C A) (B C D) (B D A) (B D C) (C A B) (C A D) (C B A) (C B D)
(C D A) (C D B) (D A B) (D A C) (D B A) (D B C) (D C A) (D C B)))
(test (permutations-with-repetition 2 '(1 2 3))
((1 1) (1 2) (1 3) (2 1) (2 2) (2 3) (3 1) (3 2) (3 3)))
(test (permutations-with-repetition 2 '(a b c d))
((A A) (A B) (A C) (A D) (B A) (B B) (B C) (B D) (C A) (C B) (C C) (C D) (D A) (D B) (D C) (D D)))
(test (combination-number 4 2) 6)
(test (combination-number 5 3) 10)
(test (combination-number 100 50) 100891344545564193334812497256)
(test (combinations 2 '(1 2 3 4))
((1 2) (1 3) (1 4) (2 3) (2 4) (3 4)))
(test (combinations 3 '(a b c d e))
((A B C) (A B D) (A B E) (A C D) (A C E) (A D E) (B C D) (B C E) (B D E) (C D E)))
(test (combinations-with-repetition 2 '(1 2 3))
((1 1) (1 2) (1 3) (2 2) (2 3) (3 3)))
(test (combinations-with-repetition 3 '(a b c d))
((A A A) (A A B) (A A C) (A A D) (A B B) (A B C) (A B D) (A C C) (A C D) (A D D)
(B B B) (B B C) (B B D) (B C C) (B C D) (B D D) (C C C) (C C D) (C D D) (D D D)))
```
Side effect functions example
```lisp
> (load "combination.lsp")
T
>(defun display (x) (format (standard-output) "~S~%" x))
DISPLAY
>(permutation #'display 3 '(1 2 3))
(1 2 3)
(1 3 2)
(2 1 3)
(2 3 1)
(3 1 2)
(3 2 1)
NIL
>(permutation #'display 2 '(a b c d))
(A B)
(A C)
(A D)
(B A)
(B C)
(B D)
(C A)
(C B)
(C D)
(D A)
(D B)
(D C)
NIL
>(permutation-with-repetition #'display 2 '(1 2 3))
(1 1)
(1 2)
(1 3)
(2 1)
(2 2)
(2 3)
(3 1)
(3 2)
(3 3)
NIL
>(permutation-with-repetition #'display 2 '(a b c d))
(A A)
(A B)
(A C)
(A D)
(B A)
(B B)
(B C)
(B D)
(C A)
(C B)
(C C)
(C D)
(D A)
(D B)
(D C)
(D D)
NIL
>(combination #'display 2 '(1 2 3 4))
(1 2)
(1 3)
(1 4)
(2 3)
(2 4)
(3 4)
NIL
>(combination #'display 3 '(a b c d e))
(A B C)
(A B D)
(A B E)
(A C D)
(A C E)
(A D E)
(B C D)
(B C E)
(B D E)
(C D E)
NIL
>(combination-with-repetition #'display 2 '(1 2 3))
(1 1)
(1 2)
(1 3)
(2 2)
(2 3)
(3 3)
NIL
>(combination-with-repetition #'display 3 '(a b c d))
(A A A)
(A A B)
(A A C)
(A A D)
(A B B)
(A B C)
(A B D)
(A C C)
(A C D)
(A D D)
(B B B)
(B B C)
(B B D)
(B C C)
(B C D)
(B D D)
(C C C)
(C C D)
(C D D)
(D D D)
NIL
``` eisl-5.55/documents/COMPILER.md 0000664 0000000 0000000 00000037332 15066676224 0016167 0 ustar 00root root 0000000 0000000 # Compiler
I developed a compiler for Easy-ISLisp (called the "FAST" project).
I released it in August 2017.
Here I describe the specifications, constraints, problems, etc.
# Basic idea
I referred to GCL (GNU Common Lisp) created by Mr. Hagiya, Mr. Yuasa and others.
The Easy-ISLisp (EISL) compiler converts ISLisp code to equivalent C code and gcc or clang generate an object file.
By dynamically linking this object file, EISL loads the compiled code.
The internal definitions of functions use GCC/clang extensions.
Therefore, the scope of labels and flet syntax is limited.
# Usage
EISL starts compiling with (compile-file filename).
The filename is given as a string. The compile-file function creates a C file based on a Lisp file.
It also launches GCC/clang and creates a shared object.
EISL loads this with the load function like a normal text Lisp file.
If the file extension is ".o", the load function handles dynamic linking.
### option
- (compile-file filename nil)
for debug. not remove compiled C codes.
- (compmile-file filename t)
for installer. remove compiled C codes with sudo command.
# Immediate value of small integer
The interpreter of EISL created cell objects for everything, including small integers.
For this reason, GC started soon and it was difficult to speed up.
The compiler instantiates integers from -999999999 to 999999999 to prevent cell consumption.
As a result, the calculation of the Takeuchi function and the Fibonacci sequence can be considerably speeded up.
```
> (load "tarai.o")
T
> (time (tarai 12 6 0))
Elapsed Time(second)=0.068000
> (time (fib 40))
Elapsed Time(second)=1.194000
>
```
# Tail recursive optimization
The ISLisp standard does not require tail-recursive optimization.
However, like Scheme, EISL generates code that replaces tail recursion with repetition.
It doesn't consume the stack in following code, and it's reasonably fast.
```
(defun foo (n)
(if (= n 0)
t
(foo (- n 1))))
> (load "test.o")
T
> (foo 1000000000)
T
> (time (foo 1000000000))
Elapsed Time(second)=1.789000
>
```
# Extensions for the compiler
The following non-standard functions have been implemented for use by the compiler:
| Function | Description |
| ------------------------- | ----------- |
| (subrp x) | t if x is a built-in function, nil otherwise |
| (macrop x) | t if x is a macro, nil otherwise |
| (system str) | Str Executes the string on the OS. This is for starting GCC. |
| (freedll) | Unlinks the last dynamically linked file. |
| (fixnump x) | t for small integers, nil otherwise |
| (longnump x) | t for LONGNUM, nil otherwise |
| (bignump x) | t for BIGNUM, nil otherwise |
| (readed-array-list x) | Convert an array of constants like # 2a((1 2) (3 4)) to a list ((1 2) (3 4)). |
| (ignore-toplevel-check x) | Passing t as an argument removes top-level checks such as defclass, and passing nil restores and checks. |
| (self-introduction) | Returns the symbol depending the kind of OS, because the compiler changes its behavior depending on the type of OS. |
| (macroexpand-1 x) | Expand macro once. |
| (macrexpand-all x) | Expand macro all. |
| (get-method x) | Get all methods of the generic function with name x. |
| (get-method-body x) | Get the entity of method x. |
| (get-method-priority x) | Gets the priority of method x. This is an integer value and one of AROUND=11, BEFORE=12, PRIORITY=13, AFTER=14. |
These are used to compile generic functions.
The interpreter evaluates the generic function once organizes and saves all methods,
and compiler extracts methods and converts it to SUBR.
```lisp
(format stream string)
```
has extended behavior when there are two single quotes in a string.
Special character controls such as ~% between consecutive single quotes are ignored.
Also, two consecutive single quotes are converted to one double quote.
This is useful for converting Lisp code to C code by pooling into a string stream and outputting to a file.
```
> (format (standard-output) "''hello~% world~A ''")
"hello~% world~A "NIL
>
```
# Implementation of lambda
`lambda` is supposed to define an anonymous function, but C functions must have a name.
The name is the file name supplied to compile-file + a natural number.
Free variables must be retained for static scope.
This was inspired by the GCL method.
A list of free variables that must be retained is linked to the function name symbol of lambda.
Access from the lambda body, is done with the `nth` function.
# Constraints of lambda
You can nest lambda expressions up to three deep.
Any more than that will result in an error.
Below is the quoted code from M.Hiroi's page.
This is correct code that conforms to the ISLisp specification.
```lisp
(defun id-search (start goal)
(labels ((dfs (limit path)
(if (= limit (length path))
(if (eq (car path) goal)
(print (reverse path)))
(for-each
(lambda (x)
(if (not (member x path))
(dfs limit (cons x path))))
(cdr (assoc (car path) adjacent))))))
(for ((limit 1 (+ limit 1)))
((= limit 7))
(format (standard-output) "----- ~D -----~%" limit)
(dfs limit (list start)))))
```
The EISL compiler cannot compile this code.
`lambda` generates a C function with a name at the top level.
The locally defined function `dfs` function is called from the lambda.
The `dfs` function generated as a C local definition function cannot be referenced from the C function corresponding to the generated lambda.
Therefore, in such a case, please write without using labels as shown below.
```lisp
(defun id-search (start goal)
(for ((limit 1 (+ limit 1)))
((= limit 7))
(format (standard-output) "----- ~D -----~%" limit)
(dfs limit (list start))))
(defun dfs (limit path)
(if (= limit (length path))
(if (eq (car path) goal)
(print (reverse path)))
(for-each
(lambda (x)
(if (not (member x path))
(dfs limit (cons x path))))
(cdr (assoc (car path) adjacent)))))
```
# Constraint on generic functions
### This constraint has been removed from ver2.0.
Below is the quoted code from M. Hiroi's page.
This is correct code that conforms to the ISLisp specification.
```lisp
(defgeneric hash-func (k))
(defmethod hash-func ((s ))
(for ((i 0 (+ i 1))
(a 0))
((>= i (length s)) a)
(setq a (+ (* a 8) (convert (elt s i) )))))
```
In the method definition, the argument name must work correctly even if you give it a different name in the generic function.
The interpreter evaluates this correctly.
But the compiler has the restriction that the argument names must be the same for simplicity.
I think it can be done by α conversion, but I decided to take a short-cut. It should be written as follows.
```lisp
(defgeneric hash-func (k))
(defmethod hash-func ((k ))
(for ((i 0 (+ i 1))
(a 0))
((>= i (length k)) a)
(setq a (+ (* a 8) (convert (elt k i)