+++ /dev/null
-#
-# Productions for the INTERCAL distribution
-#
-
-# Common prefix for machine-independent installed files.
-prefix = @prefix@
-# Common prefix for machine-dependent installed files.
-exec_prefix = @exec_prefix@
-
-# Directory in which to install binaries.
-bindir = @bindir@
-# Directory in which to install libraries.
-libdir = @libdir@
-# Directory to install data files.
-datadir = @datadir@/intercal-@PACKAGE_VERSION@
-# Directory to install the include files in.
-incdir = @includedir@/intercal-@PACKAGE_VERSION@
-
-# Program to install binaries
-INSTALL_PROGRAM = @INSTALL_PROGRAM@
-# Program to install the man page.
-INSTALL_DATA = @INSTALL_DATA@
-# Generic install program.
-INSTALL = @INSTALL@
-
-CC = @CC@
-CFLAGS = @CFLAGS@ -DICKINCLUDEDIR=\"$(incdir)\" -DICKLIBDIR=\"$(datadir)\" -DYYDEBUG
-LDFLAGS = @LDFLAGS@
-LEX = @LEX@
-LEXFLAGS=
-YACC = @YACC@
-YACCFLAGS = -d # -t
-
-LOADLIBS = @LIBS@ @INTLLIBS@ @LEXLIB@
-
-CSOURCES = ick.y lexer.l feh.c lose.c fiddle.c perpetrate.c
-ISOURCES = cesspool.c arrgghh.c ick-wrap.c
-HEADERS = ick.h lose.h sizes.h abcess.h fiddle.h feh.h
-BUILD = Makefile.in Makefile configure.ac config.h.in specgen.sh intercal.spec
-MISC = intercal.el
-DOCS = BUGS COPYING NEWS READ.ME
-SOURCES = $(CSOURCES) $(ISOURCES) $(HEADERS) $(BUILD) $(MISC) $(DOCS) pit doc
-
-all: ick libick.a
-
-ick: ick.o lexer.o feh.o lose.o fiddle.o perpetrate.o
- $(CC) perpetrate.o ick.o lexer.o feh.o lose.o fiddle.o $(LDFLAGS) -o ick
-
-y.tab.h ick.c: ick.y ick.h sizes.h feh.h lose.h
- $(YACC) -d $(YACCFLAGS) ick.y
- mv y.tab.c ick.c
-
-lexer.c: lexer.l ick.h lose.h
- $(LEX) $(LEXFLAGS) lexer.l
- mv lex.yy.c lexer.c
-
-# Uncomment the following if using a stock lex
-# LEXLIBS = -ll
-lextest: y.tab.h lexer.c ick.h lose.o
- $(CC) -DMAIN lexer.c lose.o $(LEXLIBS) -o lextest
-
-ick.o: ick.c ick.h feh.h lose.h sizes.h
-lexer.o: lexer.c y.tab.h ick.h lose.h
-feh.o: feh.c feh.h y.tab.h ick.h fiddle.h lose.h sizes.h
-perpetrate.o: perpetrate.c y.tab.h ick.h lose.h sizes.h
-cesspool.o: cesspool.c numerals.c abcess.h lose.h sizes.h
-lose.o: lose.h
-fiddle.o: fiddle.h sizes.h
-
-libick.a: cesspool.o lose.o fiddle.o arrgghh.o
- ar cr libick.a cesspool.o lose.o fiddle.o arrgghh.o
- -ranlib libick.a
-
-install: all
- cp ick $(bindir)
- cp libick.a $(libdir)
- -mkdir -p $(incdir)
- cp lose.h abcess.h fiddle.h $(incdir)
- -mkdir $(datadir)
- (cp -r pit $(datadir)/pit)
- cp ick-wrap.c $(datadir)
-
-uninstall:
- rm -f $(bindir)/ick $(libdir)/libick.a
- rm -fr $(incdir) $(datadir)
-
-intercal.spec:
- specgen.sh @PACKAGE_VERSION@ >intercal.spec
-
-TAGS: $(SOURCES)
- etags $(SOURCES)
-
-dist: intercal-@PACKAGE_VERSION@.tar.gz
-
-intercal-@PACKAGE_VERSION@.tar.gz: $(SOURCES)
- @find $(SOURCES) -type f -print | grep -v RCS | sed s:^:intercal-@PACKAGE_VERSION@/: >MANIFEST
- @(cd ..; ln -s intercal intercal-@PACKAGE_VERSION@)
- (cd ..; tar -czvf intercal/intercal-@PACKAGE_VERSION@.tar.gz `cat intercal/MANIFEST`)
- @(cd ..; rm intercal-@PACKAGE_VERSION@)
-
-RPMROOT=/usr/src/redhat
-RPM = rpmbuild
-RPMFLAGS = -ba
-rpm: dist
- cp intercal-@PACKAGE_VERSION@.tar.gz $(RPMROOT)/SOURCES;
- cp intercal.spec $(RPMROOT)/SPECS
- cd $(RPMROOT)/SPECS; $(RPM) $(RPMFLAGS) intercal.spec
- cp $(RPMROOT)/RPMS/`arch|sed 's/i[4-9]86/i386/'`/intercal-@PACKAGE_VERSION@*.rpm .
- cp $(RPMROOT)/SRPMS/intercal-@PACKAGE_VERSION@*.src.rpm .
-
-clean:
- rm -f yacc.* y.tab.* y.output *~ *.[oa] lexer.c ick.c lextest ick
- rm -f intercal-@PACKAGE_VERSION@.shar intercal-@PACKAGE_VERSION@.tar intercal-@PACKAGE_VERSION@.tar.gz intercal.spec
-
--- /dev/null
+#
+# Productions for the INTERCAL distribution
+#
+
+# Common prefix for machine-independent installed files.
+prefix = @prefix@
+# Common prefix for machine-dependent installed files.
+exec_prefix = @exec_prefix@
+
+# Directory in which to install binaries.
+bindir = @bindir@
+# Directory in which to install libraries.
+libdir = @libdir@
+# Directory to install data files.
+datadir = @datadir@/intercal-@PACKAGE_VERSION@
+# Directory to install the include files in.
+incdir = @includedir@/intercal-@PACKAGE_VERSION@
+
+# Program to install binaries
+INSTALL_PROGRAM = @INSTALL_PROGRAM@
+# Program to install the man page.
+INSTALL_DATA = @INSTALL_DATA@
+# Generic install program.
+INSTALL = @INSTALL@
+
+CC = @CC@
+CFLAGS = @CFLAGS@ -DICKINCLUDEDIR=\"$(incdir)\" -DICKLIBDIR=\"$(datadir)\" -DYYDEBUG
+LDFLAGS = @LDFLAGS@
+LEX = @LEX@
+LEXFLAGS=
+YACC = @YACC@
+YACCFLAGS = -d # -t
+
+LOADLIBS = @LIBS@ @INTLLIBS@ @LEXLIB@
+
+CSOURCES = ick.y lexer.l feh.c lose.c fiddle.c perpetrate.c
+ISOURCES = cesspool.c arrgghh.c ick-wrap.c numerals.c
+HEADERS = ick.h lose.h sizes.h abcess.h fiddle.h feh.h
+BUILD = Makefile.in Makefile configure.ac configure config.h.in specgen.sh intercal.spec install.sh
+MISC = intercal.el
+DOCS = BUGS COPYING NEWS README
+SOURCES = $(CSOURCES) $(ISOURCES) $(HEADERS) $(BUILD) $(MISC) $(DOCS) pit doc
+
+all: ick libick.a
+
+ick: ick.o lexer.o feh.o lose.o fiddle.o perpetrate.o
+ $(CC) perpetrate.o ick.o lexer.o feh.o lose.o fiddle.o $(LDFLAGS) -o ick
+
+y.tab.h ick.c: ick.y ick.h sizes.h feh.h lose.h
+ $(YACC) -d $(YACCFLAGS) ick.y
+ mv y.tab.c ick.c
+
+lexer.c: lexer.l ick.h lose.h
+ $(LEX) $(LEXFLAGS) lexer.l
+ mv lex.yy.c lexer.c
+
+# Uncomment the following if using a stock lex
+# LEXLIBS = -ll
+lextest: y.tab.h lexer.c ick.h lose.o
+ $(CC) -DMAIN lexer.c lose.o $(LEXLIBS) -o lextest
+
+ick.o: ick.c ick.h feh.h lose.h sizes.h
+lexer.o: lexer.c y.tab.h ick.h lose.h
+feh.o: feh.c feh.h y.tab.h ick.h fiddle.h lose.h sizes.h
+perpetrate.o: perpetrate.c y.tab.h ick.h lose.h sizes.h
+cesspool.o: cesspool.c numerals.c abcess.h lose.h sizes.h
+lose.o: lose.h
+fiddle.o: fiddle.h sizes.h
+
+libick.a: cesspool.o lose.o fiddle.o arrgghh.o
+ ar cr libick.a cesspool.o lose.o fiddle.o arrgghh.o
+ -ranlib libick.a
+
+install: all
+ cp ick $(bindir)
+ cp libick.a $(libdir)
+ -mkdir -p $(incdir)
+ cp lose.h abcess.h fiddle.h $(incdir)
+ -mkdir $(datadir)
+ (cp -r pit $(datadir))
+ cp ick-wrap.c $(datadir)
+
+uninstall:
+ rm -f $(bindir)/ick $(libdir)/libick.a
+ rm -fr $(incdir) $(datadir)
+
+intercal.spec:
+ specgen.sh @PACKAGE_VERSION@ >intercal.spec
+
+TAGS: $(SOURCES)
+ etags $(SOURCES)
+
+dist: intercal-@PACKAGE_VERSION@.tar.gz
+
+intercal-@PACKAGE_VERSION@.tar.gz: $(SOURCES)
+ @find $(SOURCES) -type f -print | grep -v RCS | sed s:^:intercal-@PACKAGE_VERSION@/: >MANIFEST
+ @(cd ..; ln -s intercal intercal-@PACKAGE_VERSION@)
+ (cd ..; tar -czvf intercal/intercal-@PACKAGE_VERSION@.tar.gz `cat intercal/MANIFEST`)
+ @(cd ..; rm intercal-@PACKAGE_VERSION@)
+
+VERS=@PACKAGE_VERSION@
+RPMROOT=/usr/src/redhat
+RPM = rpmbuild
+RPMFLAGS = -ba
+rpm: dist
+ cp intercal-$(VERS).tar.gz $(RPMROOT)/SOURCES;
+ cp intercal.spec $(RPMROOT)/SPECS
+ -cd $(RPMROOT)/SPECS; $(RPM) $(RPMFLAGS) intercal.spec
+ cp $(RPMROOT)/RPMS/`arch|sed 's/i[4-9]86/i386/'`/intercal-$(VERS)*.rpm .
+ cp $(RPMROOT)/SRPMS/intercal-$(VERS)*.src.rpm .
+
+clean:
+ rm -f yacc.* y.tab.* y.output *~ *.[oa] lexer.c ick.c lextest ick
+ rm -f intercal-@PACKAGE_VERSION@.tar.gz intercal.spec
+
+++ /dev/null
- Release Notes for C-INTERCAL
-
- DISCREDITS
-
-This package is an implementation of the language INTERCAL designed by Don
-Woods and James Lyon, who have since spent more than twenty years trying to
-live it down.
-
-This implementation was created by Eric S. Raymond <esr@snark.thyrsus.com>
-during a fit of lunacy from which he has since mostly recovered. It has
-been considerably hacked upon and improved by Steve Swales, Michael Ernst,
-Louis Howell, Brian Raiter, and others. For detailed credits see NEWS.
-
- FILES
-
-The compiler itself is in the src directory. Setting a symbol in the
-makefile will allow you to install it and its libraries and support files
-in a directory of your choice. The doc directory contains (surprise!)
-documentation, and pit contains various examples of INTERCAL source code,
-writhing in agony.
-
-The files included are:
-
-README -- this file
-BUGS -- current bug and to-do list
-NEWS -- info on features and fixes new in this release
-intercal.el -- elisp for editing INTERCAL code under GNU Emacs
-
-doc/READ.ME -- historical notes on the docs
-doc/intercal.mm -- the manual in groffable form
-doc/THEORY -- some notes on the internals of the INTERCAL compiler
-
-Makefile.in -- makefile for the INTERCAL compiler
-lexer.l -- the lexical analyzer specification (in LEX)
-ick.y -- the grammar specification (in YACC)
-ick.h -- compilation types and defines
-perpetrate.c -- main routine for compiler
-feh.c -- INTERCAL-to-C code generator
-feh.h -- interface to INTERCAL-to-C code generator
-fiddle.c -- the INTERCAL operators
-lose.[ch] -- INTERCAL compile- and run-time error handling
-ick-wrap.c -- the driver for generated C-from-INTERCAL code
-arrgghh.c -- option argument parsing for generated programs
-abcess.h -- interface to functions linked with programs
-cesspool.c -- the INTERCAL runtime support code
-numerals.c -- numerals table for INTERCAL input
-sizes.h -- variables defining the numeric base
-
-pit/* -- sample INTERCAL code; see pit/CATALOG
-
- HOW TO GET STARTED
-
-You want a man page? Man pages are for wimps. To compile an INTERCAL
-program `foo.i' to executable code, just do
-
- ick foo.i
-
-There's a -c option that leaves the generated `foo.c' in place for inspection
-(suppressing compilation to machine code), a -d option that enables verbose
-parse reporting from the yacc/bison parser, a -t option that requires strict
-INTERCAL-72 compliance (rejecting COME FROM and the extensions for bases other
-than two), a -b option that disables the INTERCAL-72 random-bug feature,
-and an -O option that enables the (hah!) optimizer. Invoking ick -?
-prints a usage message. Other than that, yer on yer own.
-
-Another switch affects C-INTERCAL's runtime behavior. The `-C'
-option forces output in "clockface" mode, for superstitious users who
-believe writing "IV" upside-down offends IVPITER and would rather
-see IIII.
-
-Every INTERCAL runtime also accepts certain options at runtime (code by
-Steve Swales). These include [+/-]help, [+/-]traditional, and [+/-]wimpmode.
-The help option (with either + or -) triggers a 'usage' message. The
-+traditional option is presently a no-op.
-
-Steve writes: "The wimpmode option is the most interesting. I found myself
-always running my test programs with filters on both ends to work around the
-'nifty' INTERCAL number representations. This was so painful that I decided it
-would be LESS painful (and a lot less code) if I added a 'wimp' option. With
-the +wimpmode option, the user is subjected to a humiliating message about what
-a wimp he or she is to use this mode, but after that is allowed to use
-conventional numerical notation. While such a mode doubtless violates to some
-extent the INTERCAL philosophy, the fact that a 'unbutcher' command has been
-posted clearly indicates the need for it. Anyway... if you don't like it, don't
-use it... the default is -wimpmode (i.e. NOT wimp mode)."
-
- SPREADING THE BLAME
-
-There is an INTERCAL Resource Page at http://www.catb.org/intercal
-
-The latest version of INTERCAL is also kept available at the
-Retrocomputing Museun, http://www.catb.org/retro.
-
-There is, in addition, an occasionally active USENET newsgroup devoted to the
-language: alt.lang.intercal.
-
- NOTES ON THE LINUX BUILD
-
-At the top of ick.h are two defines that you may need to remove if you
-are using lex instead of flex.
-
-Many lexes export a yylineno variable, an undocumented feature that is
-not in flex (by default). If your build fails because of redecleration
-of yylineno, comment out the define of YYLINENO_BY_HAND.
-
-Some lexes also supply a yyrestart function to begin parsing a second
-file, while others automatically restart after seeing an EOF. (This is
-the case with flex.) If your build fails at link time because
-yyrestart is not defined, comment out the define of USE_YYRESTART.
-
-If you are using gcc in an non-ANSI environment, such as SunOS, it is
-strongly recommended that you add "-Wno-unused -Wimplicit" to the gcc
-command in the makefile. If you are in an ANSI environment and are
-using the current versions of gcc, flex, and bison, C-INTERCAL should
-build with no warnings.
-
- LICENSING
-
-C-INTERCAL is now distributed under the General Public License,
-except for the C skeleton file which is explicitly *not* GPLed
-in order to avoid the (possibly mythical) "license virus" effect.
-See the file COPYING for details on the General Public License.
-
- APOCALYPSE
-
-INTERCAL is fully Y2K-compliant. Indeed, it is Y2K-obsequious, and
-loves nothing better than to be punished by relays of leather-clad and
-spike-heeled calendricists. Bite me and go buy your own shotgun.
--- /dev/null
+ Release Notes for C-INTERCAL
+
+ DISCREDITS
+
+This package is an implementation of the language INTERCAL designed by Don
+Woods and James Lyon, who have since spent more than twenty years trying to
+live it down.
+
+This implementation was created by Eric S. Raymond <esr@snark.thyrsus.com>
+during a fit of lunacy from which he has since mostly recovered. It has
+been considerably hacked upon and improved by Steve Swales, Michael Ernst,
+Louis Howell, Brian Raiter, and others. For detailed credits see NEWS.
+
+ FILES
+
+The compiler itself is in the src directory. Setting a symbol in the
+makefile will allow you to install it and its libraries and support files
+in a directory of your choice. The doc directory contains (surprise!)
+documentation, and pit contains various examples of INTERCAL source code,
+writhing in agony.
+
+The files included are:
+
+README -- this file
+BUGS -- current bug and to-do list
+NEWS -- info on features and fixes new in this release
+intercal.el -- elisp for editing INTERCAL code under GNU Emacs
+
+doc/READ.ME -- historical notes on the docs
+doc/intercal.mm -- the manual in groffable form
+doc/THEORY -- some notes on the internals of the INTERCAL compiler
+
+Makefile.in -- makefile for the INTERCAL compiler
+lexer.l -- the lexical analyzer specification (in LEX)
+ick.y -- the grammar specification (in YACC)
+ick.h -- compilation types and defines
+perpetrate.c -- main routine for compiler
+feh.c -- INTERCAL-to-C code generator
+feh.h -- interface to INTERCAL-to-C code generator
+fiddle.c -- the INTERCAL operators
+lose.[ch] -- INTERCAL compile- and run-time error handling
+ick-wrap.c -- the driver for generated C-from-INTERCAL code
+arrgghh.c -- option argument parsing for generated programs
+abcess.h -- interface to functions linked with programs
+cesspool.c -- the INTERCAL runtime support code
+numerals.c -- numerals table for INTERCAL input
+sizes.h -- variables defining the numeric base
+
+pit/* -- sample INTERCAL code; see pit/CATALOG
+
+ HOW TO GET STARTED
+
+You want a man page? Man pages are for wimps. To compile an INTERCAL
+program `foo.i' to executable code, just do
+
+ ick foo.i
+
+There's a -c option that leaves the generated `foo.c' in place for inspection
+(suppressing compilation to machine code), a -d option that enables verbose
+parse reporting from the yacc/bison parser, a -t option that requires strict
+INTERCAL-72 compliance (rejecting COME FROM and the extensions for bases other
+than two), a -b option that disables the INTERCAL-72 random-bug feature,
+and an -O option that enables the (hah!) optimizer. Invoking ick -?
+prints a usage message. Other than that, yer on yer own.
+
+Another switch affects C-INTERCAL's runtime behavior. The `-C'
+option forces output in "clockface" mode, for superstitious users who
+believe writing "IV" upside-down offends IVPITER and would rather
+see IIII.
+
+Every INTERCAL runtime also accepts certain options at runtime (code by
+Steve Swales). These include [+/-]help, [+/-]traditional, and [+/-]wimpmode.
+The help option (with either + or -) triggers a 'usage' message. The
++traditional option is presently a no-op.
+
+Steve writes: "The wimpmode option is the most interesting. I found myself
+always running my test programs with filters on both ends to work around the
+'nifty' INTERCAL number representations. This was so painful that I decided it
+would be LESS painful (and a lot less code) if I added a 'wimp' option. With
+the +wimpmode option, the user is subjected to a humiliating message about what
+a wimp he or she is to use this mode, but after that is allowed to use
+conventional numerical notation. While such a mode doubtless violates to some
+extent the INTERCAL philosophy, the fact that a 'unbutcher' command has been
+posted clearly indicates the need for it. Anyway... if you don't like it, don't
+use it... the default is -wimpmode (i.e. NOT wimp mode)."
+
+ SPREADING THE BLAME
+
+There is an INTERCAL Resource Page at http://www.catb.org/intercal
+
+The latest version of INTERCAL is also kept available at the
+Retrocomputing Museun, http://www.catb.org/retro.
+
+There is, in addition, an occasionally active USENET newsgroup devoted to the
+language: alt.lang.intercal.
+
+ NOTES ON THE LINUX BUILD
+
+At the top of ick.h are two defines that you may need to remove if you
+are using lex instead of flex.
+
+Many lexes export a yylineno variable, an undocumented feature that is
+not in flex (by default). If your build fails because of redecleration
+of yylineno, comment out the define of YYLINENO_BY_HAND.
+
+Some lexes also supply a yyrestart function to begin parsing a second
+file, while others automatically restart after seeing an EOF. (This is
+the case with flex.) If your build fails at link time because
+yyrestart is not defined, comment out the define of USE_YYRESTART.
+
+If you are using gcc in an non-ANSI environment, such as SunOS, it is
+strongly recommended that you add "-Wno-unused -Wimplicit" to the gcc
+command in the makefile. If you are in an ANSI environment and are
+using the current versions of gcc, flex, and bison, C-INTERCAL should
+build with no warnings.
+
+ LICENSING
+
+C-INTERCAL is now distributed under the General Public License,
+except for the C skeleton file which is explicitly *not* GPLed
+in order to avoid the (possibly mythical) "license virus" effect.
+See the file COPYING for details on the General Public License.
+
+ APOCALYPSE
+
+INTERCAL is fully Y2K-compliant. Indeed, it is Y2K-obsequious, and
+loves nothing better than to be punished by relays of leather-clad and
+spike-heeled calendricists. Bite me and go buy your own shotgun.
--- /dev/null
+/* abcess.h -- functions used by compiled INTERCAL programs */
+
+typedef int bool;
+#define TRUE 1
+#define FALSE 0
+
+#define ONESPOT 0
+#define TWOSPOT 1
+#define TAIL 2
+#define HYBRID 3
+
+/* the following two types must both promote to unsigned int in expressions */
+
+typedef unsigned short type16;
+typedef unsigned int type32;
+
+typedef struct array_t
+{
+ unsigned int rank;
+ unsigned int *dims;
+ union
+ {
+ type16 *tail;
+ type32 *hybrid;
+ } data;
+} array;
+
+/* defined in cesspool.c */
+extern void pushnext(int n);
+extern unsigned int popnext(int n);
+extern unsigned int resume(unsigned int n);
+extern unsigned int pin(void);
+extern void clockface(bool mode);
+extern void pout(unsigned int val);
+extern void binin(unsigned int type, array *a, bool forget);
+extern void binout(unsigned int type, array *a);
+extern unsigned int assign(char *dest, unsigned int type, bool forget,
+ unsigned int value);
+
+#ifdef _POSIX_SOURCE
+extern char *aref(unsigned int type, ...);
+extern void resize(unsigned int type, ...);
+#else
+extern char *aref();
+extern void resize();
+#endif
+
+extern void stashinit(void);
+extern void stash(unsigned int type, unsigned int index, void *from);
+extern void retrieve(void *to, int type, unsigned int index, bool forget);
+extern unsigned int roll(unsigned int n);
+
+/* defined in arrgghh.c */
+extern void parseargs(int argc, char **argv);
+
+/* abcess.h ends here */
--- /dev/null
+/*
+ * SYNOPSIS: parseargs(argc,argv)
+ * FILE : parseargs.c
+ * AUTHOR : Steve Swales
+ * DATE: October 7, 1990
+ * PURPOSE: Parse arguments for INTERCAL programs.
+ *
+LICENSE TERMS
+ Copyright (C) 1996 Eric S. Raymond
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ */
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <string.h>
+#include "abcess.h"
+#include "lose.h"
+
+int traditional = 0;
+int wimp_mode = 0;
+
+void
+parseargs(int argc, char **argv)
+{
+ register int i, j;
+ static int helpflag = -1;
+ static char *flags[] = {
+ "help",
+ "wimpmode",
+ "traditional"
+ };
+ static int *bools[] = {
+ &helpflag,
+ &wimp_mode,
+ &traditional
+ };
+ static int nflags = (int)(sizeof(flags)/sizeof(flags[0]));
+
+ for(i = 1;i < argc;i++) {
+ if(argv[i][0] != '+' && argv[i][0] != '-') {
+ break;
+ }
+ for(j = 0; j < nflags;j++) {
+ if(0 == strcmp(argv[i]+1,flags[j])) {
+ *(bools[j]) = (argv[i][0] == '+');
+ break;
+ }
+ }
+ if(j == nflags) {
+ fprintf(stderr,"%s: can't grok %s\n",argv[0],argv[i]);
+ helpflag = 1;
+ }
+ }
+ if(helpflag != -1) {
+ if(!helpflag) {
+ fprintf(stderr,
+ "Once you start messing with INTERCAL... \n");
+ fprintf(stderr,"\t\tthere is no help for you!\n\n");
+ sleep(3);
+ }
+ fprintf(stderr,"Current flags (and current state) are:\n");
+ for(i = 0;i < nflags;i++) {
+ fprintf(stderr,"\t[+/-]%-20.20s\t(%s)\n",flags[i],
+ (*(bools[i]) == 1)?"ON":((*(bools[i]) == 0)?"OFF":"???"));
+ }
+ fprintf(stderr,"All flags must be preceded by either + or -, which\n");
+ fprintf(stderr," usually will mean turn on or turn off something,\n");
+ fprintf(stderr," but not always, and not all of them currently\n");
+ fprintf(stderr," do anything, but you can switch them on or off\n");
+ fprintf(stderr," if you like anyway. Isn't this helpful?\n\n");
+ fflush(stderr);
+ sleep(3);
+ lose(E778, 0, (char *)NULL);
+ }
+ if(wimp_mode) {
+ fprintf(stderr,"How sad... you have selected to run an INTERCAL\n");
+ fprintf(stderr,"program in WIMP MODE.\n\n");
+ fprintf(stderr,"This means that:\n");
+ fprintf(stderr," A) Rather than the nifty input like:\n");
+ fprintf(stderr,"\tONE NINER SEVEN TWO OH SIX THREE,\n");
+ fprintf(stderr," and even niftier output like:\n");
+ fprintf(stderr,"\t______\n");
+ fprintf(stderr,"\tMCMLXXMMLXIII,\n");
+ fprintf(stderr," you will have to settle for plain old number\n");
+ fprintf(stderr," representations like 1972063; and,\n");
+ fprintf(stderr," B) You are a WIMP!\n\n");
+ fflush(stderr);
+ }
+}
--- /dev/null
+/*****************************************************************************
+
+NAME
+ cesspool.c -- storage management and runtime support for INTERCAL
+
+LICENSE TERMS
+ Copyright (C) 1996 Eric S. Raymond
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+***************************************************************************/
+/* LINTLIBRARY */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+
+#ifdef _POSIX_SOURCE
+#include <stdarg.h>
+#else
+#include <varargs.h>
+#endif
+
+#include "sizes.h"
+#include "abcess.h"
+#include "lose.h"
+
+#include "numerals.c"
+
+/**********************************************************************
+ *
+ * The following functions manipulate the nexting stack
+ *
+ *********************************************************************/
+
+#define MAXNEXT 80
+
+int next[MAXNEXT];
+int nextindex = 0;
+
+void pushnext(int n)
+{
+ if (nextindex < MAXNEXT)
+ next[nextindex++] = n;
+ else
+ lose(E123, lineno, (char *)NULL);
+}
+
+unsigned int popnext(int n)
+{
+ nextindex -= n;
+ if (nextindex < 0) {
+ nextindex = 0;
+ return (unsigned int)-1;
+ }
+ return(next[nextindex]);
+}
+
+unsigned int resume(unsigned int n)
+{
+ if (n == 0)
+ {
+ lose(E621, lineno, (char *)NULL);
+ return 0;
+ }
+ else if ((n = popnext(n)) == (unsigned int)-1)
+ {
+ lose(E632, lineno, (char *)NULL);
+ return 0;
+ }
+ return(n);
+}
+
+/**********************************************************************
+ *
+ * The following functions implement the INTERCAL I/O model
+ *
+ *********************************************************************/
+
+unsigned int pin(void)
+{
+ char buf[BUFSIZ], *cp, *strtok();
+ unsigned int result = 0;
+ int n;
+ extern int wimp_mode;
+
+ if (fgets(buf, BUFSIZ, stdin) == (char *)NULL)
+ lose(E562, lineno, (char *)NULL);
+ n = strlen(buf) - 1;
+ if (buf[n-1] == '\r')
+ --n;
+ buf[n] = '\0';
+
+ if(wimp_mode) {
+ result = (unsigned int)strtoul(buf, (char **)NULL, 10);
+ n = 1;
+ }
+ else
+ {
+ for(n=0,cp = strtok(buf, " ");cp;cp = strtok((char *)NULL, " "),n++)
+ {
+ int digit = -1;
+ numeral *np;
+
+ for (np = numerals; np < numerals + sizeof(numerals)/sizeof(numeral); np++)
+ if (strcmp(np->name, cp) == 0)
+ {
+ digit = np->value;
+ break;
+ }
+
+ if (digit == -1)
+ lose(E579, lineno, cp);
+
+ if (result < 429496729 || (result == 429496729 && digit < 6))
+ result = result * 10 + digit;
+ else
+ lose(E533, lineno, (char *)NULL);
+ }
+ }
+ if (!n)
+ lose(E562, lineno, (char *)NULL);
+ if (result > (unsigned int)Max_large)
+ lose(E533, lineno, (char *)NULL);
+ return(result);
+}
+
+/**********************************************************************
+ *
+ * Butchered Roman numerals implemented by
+ * Michael Ernst, mernst@theory.lcs.mit.edu. May 7, 1990
+ *
+ * The INTERCAL manual hints that 3999 should translate to MMMIM
+ * (compare MMMCMXCIX) without specifying what the translation is.
+ * That may be a typo; in any case, this implementation isn't that
+ * butchered.
+ *
+ *********************************************************************/
+
+#define MAXDIGITS 10 /* max base 10 digits */
+#define MAXROMANS (MAXDIGITS*4+1) /* max chars in translation */
+
+/*
+ * The first column tells how many of the succeeding columns are used.
+ * The other columns refer to the columns of br_equiv and br_overbar.
+ */
+static int br_trans[10][5] =
+{
+ {0, 0, 0, 0, 0},
+ {1, 0, 0, 0, 0},
+ {2, 0, 0, 0, 0},
+ {3, 0, 0, 0, 0},
+ {2, 1, 2, 0, 0}, /* or use {4, 0, 0, 0, 0} */
+ {1, 2, 0, 0, 0},
+ {2, 2, 1, 0, 0},
+ {3, 2, 1, 1, 0},
+ {4, 2, 1, 1, 1},
+ {2, 1, 3, 0, 0}
+};
+
+/*
+ * butcher places in the string result the "butchered" Roman numeral for val.
+ * This string should be printed at the beginning of a line; it spans two
+ * lines and already contains newlines.
+ *
+ * 11/24/91 LHH: Removed unnecessary final newline.
+ */
+
+static void butcher(unsigned long val, char *result)
+{
+ int i, j;
+ int digitsig, digitval;
+ char res[MAXROMANS], ovb[MAXROMANS];
+
+ /* We need FOUR columns because of the odd way that M and I interact. */
+ static char br_equiv[MAXDIGITS][4] =
+ {
+ {'I', 'I', 'V', 'X'}, {'X', 'X', 'L', 'C'},
+ {'C', 'C', 'D', 'M'}, {'M', 'I', 'V', 'X'},
+ {'X', 'X', 'L', 'C'}, {'C', 'C', 'D', 'M'},
+ {'M', 'i', 'v', 'x'}, {'x', 'x', 'l', 'c'},
+ {'c', 'c', 'd', 'm'}, {'m', 'i', 'v', 'x'},
+ };
+
+ static char br_overbar[MAXDIGITS][4] =
+ {
+ {' ', ' ', ' ', ' '},
+ {' ', ' ', ' ', ' '},
+ {' ', ' ', ' ', ' '},
+ {' ', '_', '_', '_'},
+ {'_', '_', '_', '_'},
+ {'_', '_', '_', '_'},
+ {'_', ' ', ' ', ' '},
+ {' ', ' ', ' ', ' '},
+ {' ', ' ', ' ', ' '},
+ {' ', '_', '_', '_'},
+ };
+
+ if (val == 0)
+/* Final newline will be added by puts.
+ (void) strcpy(result, "_\n \n");
+*/
+ (void) strcpy(result, "_\n");
+ else
+ {
+ res[MAXROMANS-1] = 0;
+ ovb[MAXROMANS-1] = 0;
+ i = MAXROMANS-1;
+
+ /* the significance of the current digit is 10 ** digitsig */
+ for (digitsig = 0; (digitsig < MAXDIGITS) && (val > 0); digitsig++)
+ {
+ digitval = val % 10;
+ for (j = br_trans[digitval][0]; j > 0; j--)
+ {
+ /* printf("In j loop: %d %d\n", j, i); */
+ res[--i] = br_equiv[digitsig][br_trans[digitval][j]];
+ ovb[i] = br_overbar[digitsig][br_trans[digitval][j]];
+ }
+ val = val / 10;
+ }
+
+ j = i;
+ while ((*result++ = ovb[j++]))
+ continue;
+ *--result = '\n';
+
+ j = i;
+ while ((*++result = res[j++]))
+ continue;
+/* Final newline will be added by puts.
+ *result++ = '\n';
+*/
+ *result = '\0';
+ }
+}
+
+void clockface(bool mode)
+/* enable or disable clockface mode (output IIII instead of IV) */
+{
+ if (mode)
+ {
+ /* clockface mode */
+ br_trans[4][0] = 4;
+ br_trans[4][1] = 0;
+ br_trans[4][2] = 0;
+ }
+ else
+ {
+ /* normal mode */
+ br_trans[4][0] = 2;
+ br_trans[4][1] = 1;
+ br_trans[4][2] = 2;
+ }
+}
+
+void pout(unsigned int val)
+/* output in `butchered' Roman numerals; see manual, part 4.4.13 */
+{
+ char result[2*MAXROMANS+1];
+ extern int wimp_mode;
+
+ if(wimp_mode) {
+ printf("%u\n",val);
+ }
+ else {
+ butcher(val, result);
+ (void) puts(result);
+ }
+ fflush(stdout);
+}
+
+/**********************************************************************
+ *
+ * The following two routines implement bitwise I/O. They assume
+ * 8 bit characters, but there's no reason more general versions
+ * could not be written.
+ *
+ *********************************************************************/
+
+void binin(unsigned int type, array *a, bool forget)
+{
+ static unsigned int lastin = 0;
+ int c, v;
+ unsigned int i;
+
+ if (a->rank != 1)
+ lose(E241, lineno, (char *)NULL);
+
+ for (i = 0 ; i < a->dims[0] ; i++) {
+ v = ((c=getchar()) == EOF) ? 256 : (c - lastin) % 256;
+ lastin = c;
+ if (!forget) {
+ if (type == TAIL)
+ a->data.tail[i] = v;
+ else
+ a->data.hybrid[i] = v;
+ }
+ }
+}
+
+void binout(unsigned int type, array *a)
+{
+ static unsigned int lastout = 0;
+ unsigned int i, c;
+
+ if (a->rank != 1)
+ lose(E241, lineno, (char *)NULL);
+
+ for (i = 0 ; i < a->dims[0] ; i++) {
+ if (type == TAIL)
+ c = lastout - a->data.tail[i];
+ else
+ c = lastout - a->data.hybrid[i];
+ lastout = c;
+ c = (c & 0x0f) << 4 | (c & 0xf0) >> 4;
+ c = (c & 0x33) << 2 | (c & 0xcc) >> 2;
+ c = (c & 0x55) << 1 | (c & 0xaa) >> 1;
+ putchar(c);
+ if (c == '\n')
+ fflush(stdout);
+ }
+}
+
+/**********************************************************************
+ *
+ * The following assignment function performs IGNORE and type checks
+ *
+ *********************************************************************/
+
+unsigned int assign(char *dest, unsigned int type, bool forget,
+ unsigned int value)
+{
+ unsigned int retval;
+ if (type == ONESPOT || type == TAIL) {
+ if (value > (unsigned int)Max_small)
+ lose(E275, lineno, (char *)NULL);
+ if (forget)
+ retval = value;
+ else {
+ retval = *(type16*)dest;
+ *(type16*)dest = value;
+ }
+ }
+ else if (type == TWOSPOT || type == HYBRID) {
+ if (forget)
+ retval = value;
+ else {
+ retval = *(type32*)dest;
+ *(type32*)dest = value;
+ }
+ }
+ return retval;
+}
+
+/**********************************************************************
+ *
+ * The following functions implement the INTERCAL array model
+ * If _POSIX_SOURCE is defined, stdarg is used, otherwise varargs.
+ *
+ *********************************************************************/
+
+
+#ifdef _POSIX_SOURCE
+char *aref(unsigned int type, ...)
+#else
+char *aref(va_alist) va_dcl
+#endif
+/* return a pointer to the array location specified by args */
+{
+#ifndef _POSIX_SOURCE
+ unsigned int type;
+#endif
+ array *a;
+ unsigned int v;
+ va_list ap;
+ int address = 0;
+ unsigned int i;
+
+#ifdef _POSIX_SOURCE
+ va_start(ap, type);
+#else
+ va_start(ap);
+ type = va_arg(ap, unsigned int);
+#endif
+ a = va_arg(ap, array*);
+
+ if (va_arg(ap, unsigned int) != a->rank)
+ lose(E241, lineno, (char *)NULL);
+
+ for (i = 0 ; i < a->rank ; i++) {
+ v = va_arg(ap, unsigned int);
+ if (v == 0 || v > a->dims[i])
+ lose(E241, lineno, (char *)NULL);
+ address = address * a->dims[i] + v - 1;
+ }
+
+ va_end(ap);
+
+ if (type == TAIL)
+ return (char*)&a->data.tail[address];
+ else
+ return (char*)&a->data.hybrid[address];
+}
+
+#ifdef _POSIX_SOURCE
+void resize(unsigned int type, ...)
+#else
+void resize(va_alist) va_dcl
+#endif
+/* resize an array to the given shape */
+{
+#ifndef _POSIX_SOURCE
+ unsigned int type;
+#endif
+ array *a;
+ bool forget;
+ unsigned int i, r, v;
+ va_list ap;
+ int prod = 1;
+
+#ifdef _POSIX_SOURCE
+ va_start(ap, type);
+#else
+ va_start(ap);
+ type = va_arg(ap, unsigned int);
+#endif
+ a = va_arg(ap, array*);
+ forget = va_arg(ap, bool);
+
+ r = va_arg(ap, unsigned int);
+ if (!forget) {
+ a->rank = r;
+ if (a->dims)
+ free((char*)a->dims);
+ a->dims = (unsigned int*) malloc(a->rank * sizeof(unsigned int));
+ if (a->dims == NULL)
+ lose(E241, lineno, (char *)NULL);
+ }
+
+ for (i = 0 ; i < r ; i++) {
+ v = va_arg(ap, unsigned int);
+ if (v == 0)
+ lose(E240, lineno, (char *)NULL);
+ if (!forget) {
+ a->dims[i] = v;
+ prod *= v;
+ }
+ }
+
+ if (!forget) {
+ if (type == TAIL) {
+ if (a->data.tail)
+ free((char *)a->data.tail);
+ a->data.tail = (type16*)malloc(prod * sizeof(type16));
+ if (a->data.tail == NULL)
+ lose(E241, lineno, (char *)NULL);
+ }
+ else {
+ if (a->data.hybrid)
+ free((char *)a->data.hybrid);
+ a->data.hybrid = (type32*)malloc(prod * sizeof(type32));
+ if (a->data.hybrid == NULL)
+ lose(E241, lineno, (char *)NULL);
+ }
+ }
+
+ va_end(ap);
+}
+
+/**********************************************************************
+ *
+ * The following functions implement save/retrieve
+ *
+ *********************************************************************/
+
+typedef struct stashbox_t /* this is a save-stack element */
+{
+ unsigned int type; /* variable type */
+ unsigned int index; /* variable's index within the type */
+ union /* the data itself */
+ {
+ type16 onespot;
+ type32 twospot;
+ array *a;
+ } save;
+ struct stashbox_t *next; /* pointer to next-older stashbox */
+} stashbox;
+
+static stashbox *first;
+
+void stashinit(void)
+{
+ first = NULL;
+}
+
+static stashbox *fetch(unsigned int type, unsigned int index)
+/* find a stashed variable in the save stack and extract it */
+{
+ stashbox **pp = &first, *sp = first;
+
+ while (sp && (sp->type != type || sp->index != index)) {
+ pp = &sp->next;
+ sp = sp->next;
+ }
+ if (sp)
+ *pp = sp->next;
+
+ return (sp);
+}
+
+void stash(unsigned int type, unsigned int index, void *from)
+/* stash away the variable's value */
+{
+ /* create a new stashbox and push it onto the stack */
+ stashbox *sp = (stashbox*)malloc(sizeof(stashbox));
+ if (sp == NULL) lose(E222, lineno, (char *)NULL);
+ sp->next = first;
+ first = sp;
+
+ /* store the variable in it */
+ sp->type = type;
+ sp->index = index;
+ if (type == ONESPOT)
+ memcpy((char *)&sp->save.onespot, from, sizeof(type16));
+ else if (type == TWOSPOT)
+ memcpy((char *)&sp->save.twospot, from, sizeof(type32));
+ else if (type == TAIL || type == HYBRID) {
+ array *a = (array*)from;
+ int prod;
+ unsigned int i;
+ sp->save.a = (array*)malloc(sizeof(array));
+ if (sp->save.a == NULL) lose(E222, lineno, (char *)NULL);
+ sp->save.a->rank = a->rank;
+ sp->save.a->dims = (unsigned int*)malloc(a->rank * sizeof(unsigned int));
+ if (sp->save.a->dims == NULL) lose(E222, lineno, (char *)NULL);
+ memcpy((char*)sp->save.a->dims, (char*)a->dims,
+ a->rank * sizeof(unsigned int));
+ prod = a->rank ? 1 : 0;
+ for (i = 0 ; i < a->rank ; i++) {
+ prod *= a->dims[i];
+ }
+ if (type == TAIL) {
+ sp->save.a->data.tail =
+ (type16*)malloc(prod * sizeof(type16));
+ if (sp->save.a->data.tail == NULL) lose(E222, lineno, (char *)NULL);
+ memcpy((char *)sp->save.a->data.tail,
+ (char*)a->data.tail, prod * sizeof(type16));
+ }
+ else {
+ sp->save.a->data.hybrid =
+ (type32*)malloc(prod * sizeof(type32));
+ if (sp->save.a->data.hybrid == NULL) lose(E222, lineno, (char *)NULL);
+ memcpy((char *)sp->save.a->data.hybrid,
+ (char*)a->data.hybrid, prod * sizeof(type32));
+ }
+ }
+ return;
+}
+
+void retrieve(void *to, int type, unsigned int index, bool forget)
+/* restore the value of a variable from the save stack */
+{
+ stashbox *sp;
+
+ if ((sp = fetch(type, index)) == (stashbox *)NULL)
+ lose(E436, lineno, (char *)NULL);
+ else if (!forget) {
+ if (type == ONESPOT)
+ memcpy(to, (char *)&sp->save.onespot, sizeof(type16));
+ else if (type == TWOSPOT)
+ memcpy(to, (char *)&sp->save.twospot, sizeof(type32));
+ else if (type == TAIL || type == HYBRID) {
+ array *a = (array*)to;
+ if (a->rank) {
+ free(a->dims);
+ if (type == TAIL)
+ free(a->data.tail);
+ else
+ free(a->data.hybrid);
+ memcpy(to, (char*)sp->save.a, sizeof(array));
+ }
+ free(sp->save.a);
+ }
+ }
+ else if (type == TAIL || type == HYBRID) {
+ free(sp->save.a->dims);
+ if (type == TAIL)
+ free(sp->save.a->data.tail);
+ else
+ free(sp->save.a->data.hybrid);
+ free(sp->save.a);
+ }
+ free(sp);
+}
+
+/**********************************************************************
+ *
+ * The following function is used for random decision making
+ *
+ *********************************************************************/
+
+unsigned int roll(unsigned int n)
+/* return TRUE on n% chance, FALSE otherwise */
+{
+#ifdef USG
+ return((unsigned int)(lrand48() % 100) < n);
+#else
+ return((unsigned int)(rand() % 100) < n);
+#endif /* UNIX */
+}
+
+/* cesspool.c ends here */
version but absent in the ASCII transcription are instead poorly
approximated with ASCII boxology, (c) every "butchered Roman numeral"
is preceded and followed by a line break, (d) the hanging-indent list
-of Princeton compiler options is has all marks above each description,
+of Princeton compiler options has all marks above each description,
rather than to its left.
The aim of these changes was to reduce to one the number of manual masters that
--- /dev/null
+/****************************************************************************
+
+NAME
+ feh.c -- code-generator back-end for ick parser
+
+DESCRIPTION
+ This module provides storage manglement, code degeneration,
+and optimizations of dubious value for the INTERCAL compiler.
+
+LICENSE TERMS
+ Copyright (C) 1996 Eric S. Raymond
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+****************************************************************************/
+/*LINTLIBRARY */
+#include <stdio.h>
+#include <stdlib.h>
+#include <string.h>
+#include "sizes.h"
+#include "ick.h"
+#include "y.tab.h"
+#include "fiddle.h"
+#include "lose.h"
+#include "feh.h"
+
+static int emitlineno; /* line number for errors encountered during emit */
+
+/*************************************************************************
+ *
+ * Node allocation functions.
+ *
+ * Nodes are used to represent expresion trees. The emit() function
+ * deallocates them.
+ *
+ **************************************************************************/
+
+node *newnode(void)
+/* allocate and zero out a new expression node */
+{
+ return((node *)calloc(sizeof(node), 1));
+}
+
+node *cons(int type, node *car, node *cdr)
+{
+ node *np = newnode();
+
+ np->opcode = type;
+ np->lval = car;
+ np->rval = cdr;
+
+ return(np);
+}
+
+/*************************************************************************
+ *
+ * Variable-name mapping
+ *
+ * This permits us to optimize use of variable storage at runtime
+ *
+ **************************************************************************/
+
+unsigned int intern(int type, int index)
+{
+ atom *x;
+
+ if (index < 1 || index > 65535)
+ lose(E200, yylineno, (char *)NULL);
+
+ if (!oblist)
+ {
+ /* initialize oblist and obdex */
+ oblist = malloc(ALLOC_CHUNK * sizeof(atom));
+ if (!oblist)
+ lose(E778, yylineno, (char *)NULL);
+ obdex = oblist;
+ obcount = ALLOC_CHUNK;
+ }
+
+ /* if it's already on the oblist, return its intindex */
+ for (x = oblist; x < obdex; x++)
+ if (x->type == type && x->extindex == index)
+ return(x->intindex);
+
+ /* else we must intern a new symbol */
+ if (obdex >= oblist + obcount)
+ {
+ obcount += ALLOC_CHUNK;
+ x = realloc(oblist, obcount * sizeof(atom));
+ if (!x)
+ lose(E333, yylineno, (char *)NULL);
+ obdex = x + (obdex - oblist);
+ oblist = x;
+ }
+ obdex->type = type;
+ obdex->extindex = index;
+ if (type == ONESPOT)
+ obdex->intindex = nonespots++;
+ if (type == TWOSPOT)
+ obdex->intindex = ntwospots++;
+ if (type == TAIL)
+ obdex->intindex = ntails++;
+ if (type == HYBRID)
+ obdex->intindex = nhybrids++;
+ ++obdex;
+
+ return(obdex[-1].intindex);
+}
+
+/*************************************************************************
+ *
+ * This function insures a label is valid.
+ *
+ **************************************************************************/
+
+void checklabel(int label)
+{
+ if (label < 1 || label > 65535)
+ lose(E197, yylineno, (char *)NULL);
+}
+
+/*************************************************************************
+ *
+ * Tuple allocation functions.
+ *
+ **************************************************************************/
+
+void treset(void)
+{
+ tuplecount = 0;
+ if (tuples)
+ {
+ free(tuples);
+ tuples = NULL;
+ }
+ nonespots = ntwospots = ntails = nhybrids = 0;
+ obdex = oblist;
+ lineno = 0;
+}
+
+tuple *newtuple(void)
+/* allocate and zero out a new expression tuple */
+{
+ if (lineno >= tuplecount)
+ {
+ tuplecount += ALLOC_CHUNK;
+ if (tuples)
+ tuples = realloc(tuples, tuplecount * sizeof(tuple));
+ else
+ tuples = malloc(tuplecount * sizeof(tuple));
+ if (!tuples)
+ {
+ lose(E666, yylineno, (char *)NULL);
+ return NULL;
+ }
+ memset(tuples + lineno, 0, (tuplecount - lineno) * sizeof(tuple));
+ }
+ return(tuples + lineno++);
+}
+
+/*************************************************************************
+ *
+ * The typecaster
+ *
+ * The theory here is that we associate a type with each node in order to
+ * know what widths of unary-logical operator to use.
+ *
+ **************************************************************************/
+
+void typecast(node *np)
+{
+ /* recurse so we typecast each node after all its subnodes */
+ if (np == (node *)NULL)
+ return;
+ else if (np->lval != (node *)NULL)
+ typecast(np->lval);
+ if (np->rval != (node *)NULL)
+ typecast(np->rval);
+
+ /*
+ * This is an entire set of type-deducing machinery right here.
+ */
+ if (np->opcode == MESH || np->opcode == ONESPOT || np->opcode == TAIL)
+ np->width = 16;
+ else if (np->opcode == TWOSPOT || np->opcode == HYBRID
+ || np->opcode == MINGLE || np->opcode == MESH32)
+ np->width = 32;
+ else if (np->opcode == AND || np->opcode == OR || np->opcode == XOR ||
+ np->opcode == FIN ||
+ (np->opcode >= WHIRL && np->opcode <= WHIRL5))
+ np->width = np->rval->width;
+ else if (np->opcode == SELECT)
+ np->width = np->rval->width; /* n-bit select has an n-bit result */
+ else if (np->opcode == SUB)
+ np->width = np->lval->width; /* type of the array */
+}
+
+/*************************************************************************
+ *
+ * The codechecker
+ *
+ * This checks for nasties like mismatched types in assignments that
+ * can be detected at compile time -- also for errors that could cause
+ * the compilation of the generated C to fail, like generated gotos to
+ * nonexistent labels or duplicate labels.
+ *
+ **************************************************************************/
+
+void codecheck(void)
+{
+ tuple *tp, *up;
+
+ /* check for assignment type mismatches */
+ /* This check can't be done at compile time---RTFM. [LHH] */
+/*
+ for (tp = tuples; tp < tuples + lineno; tp++)
+ if (tp->type == GETS)
+ if (tp->u.node->lval->width == 16 && tp->u.node->rval->width == 32)
+ lose(E275, tp - tuples + 1, (char *)NULL);
+*/
+
+ /* check for duplicate labels */
+ for (tp = tuples; tp < tuples + lineno; tp++)
+ if (tp->label)
+ for (up = tuples; up < tuples + lineno; up++)
+ if (tp != up && tp->label == up->label)
+ lose(E182, tp - tuples + 1, (char *)NULL);
+
+ /*
+ * Check that every NEXT, ABSTAIN, REINSTATE and COME_FROM actually has a
+ * legitimate target label.
+ */
+ for (tp = tuples; tp < tuples + lineno; tp++)
+ if (tp->type == NEXT
+ || tp->type == ABSTAIN || tp->type == REINSTATE
+ || tp->type == COME_FROM)
+ {
+ bool foundit = FALSE;
+
+ for (up = tuples; up < tuples + lineno; up++)
+ if (tp->u.target == up->label)
+ {
+ foundit = TRUE;
+ break;
+ }
+
+ if (!foundit)
+ {
+ if (tp->type == NEXT)
+ lose(E129, tp - tuples + 1, (char *)NULL);
+ else if (tp->type == COME_FROM)
+ lose(E444, tp - tuples + 1, (char *)NULL);
+ else
+ lose(E139, tp - tuples + 1, (char *)NULL);
+ }
+ /* tell the other tuple if it is a COME FROM target */
+ else if (tp->type == COME_FROM)
+ {
+ if (up->comefrom)
+ lose(E555, yylineno, (char *)NULL);
+ else
+ up->comefrom = tp - tuples + 1;
+ }
+ /* this substitutes line numbers for label numbers */
+ else if (tp->type != NEXT)
+ {
+ tp->u.target = up - tuples + 1;
+ }
+ }
+}
+
+/*************************************************************************
+ *
+ * Optimizer code.
+ *
+ * It's not a very good optimizer, is it?
+ *
+ **************************************************************************/
+
+void optimize(node *np)
+{
+ node *mingleop, *op;
+
+ /* recurse so we simplify each node after all its subnodes */
+ if (np == (node *)NULL)
+ return;
+ else if (np->lval != (node *)NULL)
+ optimize(np->lval);
+ if (np->rval != (node *)NULL)
+ optimize(np->rval);
+
+ /*
+ * OK, now do complete folding of constant expressions.
+ */
+
+ /* fold MINGLE operations on constants */
+ if (np->opcode==MINGLE && (np->lval->opcode==MESH&&np->rval->opcode==MESH))
+ {
+ np->opcode = MESH32;
+ np->constant = mingle(np->lval->constant, np->rval->constant);
+ free(np->lval);
+ free(np->rval);
+ }
+
+ /* fold SELECT operations on constants */
+ if (np->opcode == SELECT
+ && ((np->lval->opcode==MESH || np->lval->opcode==MESH32)
+ && (np->rval->opcode==MESH || np->rval->opcode==MESH32)))
+ {
+ np->opcode = np->rval->opcode;
+ np->constant = iselect(np->lval->constant, np->rval->constant);
+ free(np->lval);
+ free(np->rval);
+ }
+
+ /* fold AND operations on 16-bit constants */
+ if (np->opcode == AND && np->rval->opcode == MESH)
+ {
+ np->opcode = MESH;
+ np->constant = and16(np->rval->constant);
+ free(np->rval);
+ }
+
+ /* fold AND operations on 32-bit constants */
+ if (np->opcode == AND && np->rval->opcode == MESH32)
+ {
+ np->opcode = MESH32;
+ np->constant = and32(np->rval->constant);
+ free(np->rval);
+ }
+
+ /* fold OR operations on 16-bit constants */
+ if (np->opcode == OR && np->rval->opcode == MESH)
+ {
+ np->opcode = MESH;
+ np->constant = or16(np->rval->constant);
+ free(np->rval);
+ }
+
+ /* fold OR operations on 32-bit constants */
+ if (np->opcode == OR && np->rval->opcode == MESH32)
+ {
+ np->opcode = MESH32;
+ np->constant = or32(np->rval->constant);
+ free(np->rval);
+ }
+
+ /* fold XOR operations on 16-bit constants */
+ if (np->opcode == XOR && np->rval->opcode == MESH)
+ {
+ np->opcode = MESH;
+ np->constant = xor16(np->rval->constant);
+ free(np->rval);
+ }
+
+ /* fold XOR operations on 32-bit constants */
+ if (np->opcode == XOR && np->rval->opcode == MESH32)
+ {
+ np->opcode = MESH32;
+ np->constant = xor32(np->rval->constant);
+ free(np->rval);
+ }
+
+ /*
+ * Less trivial stuff begins here
+ */
+
+ /* following optimizations only work in binary */
+ if (Base != 2)
+ return;
+
+ /* recognize the idioms for various C binary logical operations */
+ if (np->opcode == SELECT
+ && np->rval->opcode == MESH32 && np->rval->constant == 0x55555555
+ && (op = np->lval)
+ && (op->opcode == AND || op->opcode == OR || op->opcode == XOR)
+ && (mingleop = op->rval) && mingleop->opcode == MINGLE
+ && mingleop->rval->width == 16
+ && mingleop->lval->width == 16)
+ {
+ np->lval = mingleop->lval;
+ np->rval = mingleop->rval;
+
+ switch(op->opcode)
+ {
+ case AND: np->opcode = C_AND; break;
+ case OR: np->opcode = C_OR; break;
+ case XOR: np->opcode = C_XOR; break;
+ default: lose(E778, yylineno, (char *)NULL);
+ }
+
+ free(mingleop); free(op);
+ }
+
+ /* recognize idioms for ~ */
+ if (np->opcode == C_XOR)
+ {
+ if (np->rval->width == 16
+ && np->lval->opcode == MESH &&np->lval->constant == 0xffff)
+ {
+ np->opcode = C_NOT;
+ free(np->lval);
+ }
+
+ if (np->lval->width == 16
+ && np->rval->opcode == MESH && np->rval->constant == 0xffff)
+ {
+ np->opcode = C_NOT;
+ free(np->rval);
+ np->rval = np->lval;
+ }
+
+ if (np->rval->width == 32
+ && np->lval->opcode == MESH32 && np->lval->constant == 0xffffffffL)
+ {
+ np->opcode = C_NOT;
+ free(np->lval);
+ }
+
+ if (np->lval->width == 32
+ && np->rval->opcode == MESH32 && np->rval->constant == 0xffffffffL)
+ {
+ np->opcode = C_NOT;
+ free(np->rval);
+ np->rval = np->lval;
+ }
+ }
+}
+
+/*************************************************************************
+ *
+ * Code degeneration
+ *
+ * The theory behind this crock is that we've been handed a pointer to
+ * a tuple representing a single INTERCAL statement, possibly with an
+ * expression tree hanging off it and twisting slowly, slowly in the wind.
+ *
+ * Our mission, should we choose to accept it, is to emit C code which,
+ * when linked to the INTERCAL run-time support, will do something
+ * resembling the right thing.
+ *
+ **************************************************************************/
+
+/*
+ * If the order of statement-token defines in ick.y ever changes,
+ * this will need to be reordered.
+ */
+char *enablers[MAXTYPES] =
+{
+ "GETS",
+ "RESIZE",
+ "NEXT",
+ "FORGET",
+ "RESUME",
+ "STASH",
+ "RETRIEVE",
+ "IGNORE",
+ "REMEMBER",
+ "ABSTAIN",
+ "REINSTATE",
+ "DISABLE",
+ "ENABLE",
+ "GIVE_UP",
+ "READ_OUT",
+ "WRITE_IN",
+ "COME_FROM",
+};
+
+assoc vartypes[] =
+{
+ { ONESPOT, "ONESPOT" },
+ { TWOSPOT, "TWOSPOT" },
+ { TAIL, "TAIL" },
+ { HYBRID, "HYBRID" },
+ { 0, (char *)NULL }
+};
+
+static assoc forgetbits[] =
+{
+ { ONESPOT, "oneforget" },
+ { TWOSPOT, "twoforget" },
+ { TAIL, "tailforget" },
+ { HYBRID, "hyforget" },
+ { 0, (char *)NULL }
+};
+
+static assoc varstores[] =
+{
+ { ONESPOT, "onespots" },
+ { TWOSPOT, "twospots" },
+ { TAIL, "tails" },
+ { HYBRID, "hybrids" },
+ { 0, (char *)NULL }
+};
+
+static assoc typedefs[] =
+{
+ { ONESPOT, "type16" },
+ { TWOSPOT, "type32" },
+ { TAIL, "type16" },
+ { HYBRID, "type32" },
+ { 0, (char *)NULL }
+};
+
+char *nameof(int value, assoc table[])
+/* return string corresponding to value in table */
+{
+ assoc *ap;
+
+ for (ap = table; ap->name; ap++)
+ if (ap->value == value)
+ return(ap->name);
+ return((char *)NULL);
+}
+
+static void prexpr(node *np, FILE *fp);
+
+static void prvar(node *np, FILE *fp)
+/* print out args to pass to storage manager for reference */
+{
+ node *sp;
+ int dim;
+
+ switch (np->opcode)
+ {
+ case ONESPOT:
+ (void) fprintf(fp, "onespots[%lu]", np->constant);
+ break;
+
+ case TWOSPOT:
+ (void) fprintf(fp, "twospots[%lu]", np->constant);
+ break;
+
+ case TAIL:
+ (void) fprintf(fp, "TAIL, &tails[%lu]", np->constant);
+ break;
+
+ case HYBRID:
+ (void) fprintf(fp, "HYBRID, &hybrids[%lu]", np->constant);
+ break;
+
+ case SUB:
+ {
+ (void) fprintf(fp, "aref(");
+ prvar(np->lval, fp);
+
+ dim = 0;
+ for (sp = np->rval ; sp ; sp = sp->rval)
+ dim++;
+ (void) fprintf(fp, ", %d", dim);
+
+ for (sp = np->rval ; sp ; sp = sp->rval) {
+ (void) fprintf(fp, ", ");
+ prexpr(sp->lval, fp);
+ }
+ (void) fprintf(fp, ")");
+ }
+ break;
+ }
+}
+
+static void prexpr(node *np, FILE *fp)
+/* print out C-function equivalent of an expression */
+{
+ switch (np->opcode)
+ {
+ case MINGLE:
+ (void) fprintf(fp, "mingle(");
+ prexpr(np->lval, fp);
+ (void) fprintf(fp, ", ");
+ prexpr(np->rval, fp);
+ (void) fprintf(fp, ")");
+ break;
+
+ case SELECT:
+ (void) fprintf(fp, "iselect(");
+ prexpr(np->lval, fp);
+ (void) fprintf(fp, ", ");
+ prexpr(np->rval, fp);
+ (void) fprintf(fp, ")");
+ break;
+
+ case AND:
+ (void) fprintf(fp, "and%d(", np->width);
+ prexpr(np->rval, fp);
+ (void) fprintf(fp, ")");
+ break;
+
+ case OR:
+ (void) fprintf(fp, "or%d(", np->width);
+ prexpr(np->rval, fp);
+ (void) fprintf(fp, ")");
+ break;
+
+ case XOR:
+ (void) fprintf(fp, "xor%d(", np->width);
+ prexpr(np->rval, fp);
+ (void) fprintf(fp, ")");
+ break;
+
+ case FIN:
+ if (Base < 3)
+ lose(E997, emitlineno, (char *)NULL);
+ (void) fprintf(fp, "fin%d(", np->width);
+ prexpr(np->rval, fp);
+ (void) fprintf(fp, ")");
+ break;
+
+ case WHIRL:
+ case WHIRL2:
+ case WHIRL3:
+ case WHIRL4:
+ case WHIRL5:
+ if (np->opcode - WHIRL + 3 > Base)
+ lose(E997, emitlineno, (char *)NULL);
+ (void) fprintf(fp, "whirl%d(%d, ", np->width, np->opcode - WHIRL + 1);
+ prexpr(np->rval, fp);
+ (void) fprintf(fp, ")");
+ break;
+
+ case MESH:
+ (void) fprintf(fp, "0x%lx", np->constant);
+ break;
+
+ case MESH32:
+ (void) fprintf(fp, "0x%lx", np->constant);
+ break;
+
+ case ONESPOT:
+ case TWOSPOT:
+ case TAIL:
+ case HYBRID:
+ prvar(np, fp);
+ break;
+
+ case SUB:
+ (void) fprintf(fp, "*(%s*)", nameof(np->lval->opcode, typedefs));
+ prvar(np, fp);
+ break;
+
+ /* cases from here down are generated by the optimizer */
+ case C_AND:
+ (void) fprintf(fp, "(");
+ prexpr(np->lval, fp);
+ (void) fprintf(fp, " & ");
+ prexpr(np->rval, fp);
+ (void) fprintf(fp, ")");
+ break;
+
+ case C_OR:
+ (void) fprintf(fp, "(");
+ prexpr(np->lval, fp);
+ (void) fprintf(fp, " | ");
+ prexpr(np->rval, fp);
+ (void) fprintf(fp, ")");
+ break;
+
+ case C_XOR:
+ (void) fprintf(fp, "(");
+ prexpr(np->lval, fp);
+ (void) fprintf(fp, " ^ ");
+ prexpr(np->rval, fp);
+ (void) fprintf(fp, ")");
+ break;
+
+ case C_NOT:
+ (void) fprintf(fp, "(~");
+ prexpr(np->rval, fp);
+ if (np->rval->width == Small_digits)
+ (void) fprintf(fp, " & Max_small)");
+ else
+ (void) fprintf(fp, " & Max_large)");
+ break;
+ }
+
+ (void) free(np);
+}
+
+static char *nice_text(char *texts[], int lines)
+{
+#define MAXNICEBUF 512
+ static char buf[MAXNICEBUF];
+ char *cp, *text;
+ int i;
+
+ if (lines < 1)
+ lines = 1;
+ for (cp = buf, i = 0 ; i < lines ; ++i) {
+ if (cp>buf+MAXNICEBUF-10) goto abort;
+ if (i) {
+ (*cp++) = '\\';
+ (*cp++) = 'n';
+ (*cp++) = '\\';
+ (*cp++) = '\n';
+ (*cp++) = '\t';
+ }
+ for (text = texts[i] ; *text ; cp++, text++) {
+ if (cp>buf+MAXNICEBUF-10) goto abort;
+ if(*text == '"' || *text == '\\') {
+ (*cp++) = '\\';
+ }
+ *cp = *text;
+ }
+ }
+ *cp = '\0';
+ return buf;
+abort: (*cp++) = '.';
+ (*cp++) = '.';
+ (*cp++) = '.';
+ *cp = '\0';
+ return buf;
+}
+
+static void emit_guard(tuple *tn, FILE *fp)
+/* emit execution guard for giiven tuple (note the unbalanced trailing {!) */
+{
+ (void) fprintf(fp, " if (");
+ if (tn->exechance < 100)
+ (void) fprintf(fp, "roll(%d) && ", tn->exechance);
+ (void) fprintf(fp, "!abstained[%d]) {\n", (int)(tn - tuples));
+}
+
+void emit(tuple *tn, FILE *fp)
+/* emit code for the given tuple */
+{
+ node *np, *sp;
+ int dim;
+
+ /* grind out label and source dump */
+ if (yydebug || compile_only)
+ (void) fprintf(fp, " /* line %03d */\n", tn->lineno);
+ if (tn->label)
+ (void) fprintf(fp, "L%d:", tn->label);
+ if (yydebug || compile_only)
+ (void) fprintf(fp, "\t/* %s */", textlines[tn->lineno]);
+ (void) fputc('\n', fp);
+
+ /* set up the "next" lexical line number for error messages */
+ if (tn->type == NEXT) {
+ tuple *up;
+ for (up = tuples; up < tuples + lineno; up++)
+ if (tn->u.target == up->label) {
+ emitlineno = up->lineno;
+ break;
+ }
+ } else if (tn->comefrom)
+ emitlineno = tuples[tn->comefrom-1].lineno;
+ else if (tn < tuples + lineno - 1)
+ emitlineno = tn[1].lineno;
+ else
+ emitlineno = yylineno;
+ (void) fprintf(fp, " lineno = %d;\n", emitlineno);
+
+ /* emit conditional-execution prefixes */
+ if (tn->type != COME_FROM)
+ emit_guard(tn, fp);
+
+ /* now emit the code for the statement body */
+ switch(tn->type)
+ {
+ case GETS:
+ np = tn->u.node;
+ if (np->lval->opcode != SUB) {
+ sp = np->lval;
+ (void) fprintf(fp,"\t(void) assign((char*)&");
+ }
+ else {
+ sp = np->lval->lval;
+ (void) fprintf(fp,"\t(void) assign(");
+ }
+ prvar(np->lval, fp);
+ (void) fprintf(fp,", %s", nameof(sp->opcode, vartypes));
+ (void) fprintf(fp,", %s[%lu], ", nameof(sp->opcode, forgetbits),
+ sp->constant);
+ prexpr(np->rval, fp);
+ (void) fprintf(fp,");\n");
+ break;
+
+ case RESIZE:
+ np = tn->u.node;
+ dim = 0;
+ for (sp = np->rval; sp; sp = sp->rval)
+ dim++;
+ (void) fprintf(fp, "\tresize(");
+ prvar(np->lval, fp);
+ (void) fprintf(fp, ", %s[%lu]", nameof(np->lval->opcode, forgetbits),
+ np->lval->constant);
+ (void) fprintf(fp, ", %d", dim);
+ for (sp = np->rval; sp; sp = sp->rval) {
+ (void) fprintf(fp, ", ");
+ prexpr(sp->lval, fp);
+ }
+ (void) fprintf(fp, ");\n");
+ break;
+
+ case NEXT:
+ (void) fprintf(fp,
+ "\tpushnext(%d); goto L%d; N%d:;\n",
+ (int)(tn - tuples + 1), tn->u.target, (int)(tn - tuples + 1));
+ break;
+
+ case RESUME:
+ (void) fprintf(fp, "\tskipto = resume(");
+ prexpr(tn->u.node, fp);
+ (void) fprintf(fp, "); goto top;\n");
+ break;
+
+ case FORGET:
+ (void) fprintf(fp, "\tpopnext(");
+ prexpr(tn->u.node, fp);
+ (void) fprintf(fp, ");\n");
+ break;
+
+ case STASH:
+ for (np = tn->u.node; np; np = np->rval)
+ (void) fprintf(fp, "\tstash(%s, %lu, %s+%lu);\n",
+ nameof(np->opcode, vartypes),
+ np->constant,
+ nameof(np->opcode, varstores), np->constant);
+ break;
+
+ case RETRIEVE:
+ for (np = tn->u.node; np; np = np->rval)
+ (void) fprintf(fp, "\tretrieve(%s+%lu, %s, %lu, %s[%lu]);\n",
+ nameof(np->opcode, varstores), np->constant,
+ nameof(np->opcode, vartypes),
+ np->constant,
+ nameof(np->opcode, forgetbits),
+ np->constant);
+ break;
+
+ case IGNORE:
+ for (np = tn->u.node; np; np = np->rval)
+ (void) fprintf(fp,"\t%s[%lu] = TRUE;\n",
+ nameof(np->opcode, forgetbits),
+ np->constant);
+ break;
+
+ case REMEMBER:
+ for (np = tn->u.node; np; np = np->rval)
+ (void) fprintf(fp,"\t%s[%lu] = FALSE;\n",
+ nameof(np->opcode, forgetbits),
+ np->constant);
+ break;
+
+ case ABSTAIN:
+ (void) fprintf(fp, "\tabstained[%d] = TRUE;\n", tn->u.target - 1);
+ break;
+
+ case REINSTATE:
+ (void) fprintf(fp, "\tabstained[%d] = FALSE;\n", tn->u.target - 1);
+ break;
+
+ case ENABLE:
+ (void) fprintf(fp,
+ "\tint i;\n");
+ for (np = tn->u.node; np; np = np->rval)
+ {
+ (void) fprintf(fp,
+ "\n\tfor (i = 0; i < (int)(sizeof(linetype)/sizeof(int)); i++)\n");
+ if (np->constant == ABSTAIN || np->constant == REINSTATE) {
+ (void) fprintf(fp,
+ "\t if (linetype[i] == %s || linetype[i] == %s)\n", enablers[np->constant-GETS], enablers[np->constant-GETS+2]);
+ } else {
+ (void) fprintf(fp,
+ "\t if (linetype[i] == %s)\n", enablers[np->constant-GETS]);
+ }
+ (void) fprintf(fp,
+ "\t\tabstained[i] = FALSE;\n");
+ }
+ break;
+
+ case DISABLE:
+ (void) fprintf(fp,
+ "\tint i;\n");
+ for (np = tn->u.node; np; np = np->rval)
+ {
+ (void) fprintf(fp,
+ "\n\tfor (i = 0; i < (int)(sizeof(linetype)/sizeof(int)); i++)\n");
+ if (np->constant == ABSTAIN || np->constant == REINSTATE) {
+ (void) fprintf(fp,
+ "\t if (linetype[i] == %s || linetype[i] == %s)\n", enablers[np->constant-GETS], enablers[np->constant-GETS+2]);
+ } else {
+ (void) fprintf(fp,
+ "\t if (linetype[i] == %s)\n", enablers[np->constant-GETS]);
+ }
+ (void) fprintf(fp,
+ "\t\tabstained[i] = TRUE;\n");
+ }
+ break;
+
+ case GIVE_UP:
+ (void) fprintf(fp, "\treturn(0);\n");
+ break;
+
+ case WRITE_IN:
+ for (np = tn->u.node; np; np = np->rval) {
+ if (np->lval->opcode == TAIL || np->lval->opcode == HYBRID) {
+ (void) fprintf(fp,"\tbinin(");
+ prvar(np->lval, fp);
+ (void) fprintf(fp, ", %s[%lu]",
+ nameof(np->lval->opcode, forgetbits),
+ np->lval->constant);
+ (void) fprintf(fp,");\n");
+ }
+ else {
+ if (np->lval->opcode != SUB) {
+ sp = np->lval;
+ (void) fprintf(fp,"\t(void) assign((char*)&");
+ }
+ else {
+ sp = np->lval->lval;
+ (void) fprintf(fp,"\t(void) assign(");
+ }
+ prvar(np->lval, fp);
+ (void) fprintf(fp,", %s", nameof(sp->opcode, vartypes));
+ (void) fprintf(fp,", %s[%lu]", nameof(sp->opcode, forgetbits),
+ sp->constant);
+ (void) fprintf(fp,", pin());\n");
+ }
+ }
+ break;
+
+ case READ_OUT:
+ for (np = tn->u.node; np; np = np->rval)
+ {
+ if (np->lval->opcode == TAIL || np->lval->opcode == HYBRID) {
+ (void) fprintf(fp,"\tbinout(");
+ prvar(np->lval, fp);
+ (void) fprintf(fp,");\n");
+ }
+ else {
+ (void) fprintf(fp, "\tpout(");
+ prexpr(np->lval, fp);
+ (void) fprintf(fp, ");\n");
+ }
+ }
+ break;
+
+ case SPLATTERED:
+ dim = emitlineno - tn->lineno;
+ if (tn->sharedline)
+ ++dim;
+ (void) fprintf(fp, "\tlose(E000, %d, \"%s\");\n",
+ emitlineno, nice_text(textlines + tn->lineno, dim));
+ break;
+
+ case COME_FROM:
+ (void) fprintf(fp, "C%d:\n", tn->u.target);
+ break;
+
+ default:
+ lose(E778, emitlineno, (char *)NULL);
+ break;
+ }
+
+ if (tn->type != COME_FROM)
+ (void) fprintf(fp, " }\n");
+
+ /*
+ * If the statement that was just degenerated was a COME FROM target,
+ * emit the code for the jump to the COME FROM.
+ */
+ if (tn->comefrom) {
+ if (yydebug || compile_only)
+ (void) fprintf(fp,
+ " /* line %03d is a suck point for the COME FROM at line %03d */\n",
+ tn->lineno, tuples[tn->comefrom-1].lineno);
+ emit_guard(tuples + tn->comefrom - 1, fp);
+ (void) fprintf(fp,
+ "\tgoto C%d;\n }\n",
+ tuples[tn->comefrom-1].u.target);
+ }
+}
+
+/* feh.c ends here */
--- /dev/null
+/* feh.h -- compilation functions used by perpetrate.c and ick.y */
+
+extern node *newnode(void);
+extern node *cons(int type, node *car, node *cdr);
+extern unsigned int intern(int type, int index);
+extern void checklabel(int label);
+extern void treset(void);
+extern tuple *newtuple(void);
+extern void typecast(node *np);
+extern void codecheck(void);
+extern void optimize(node *np);
+extern char *nameof(int value, assoc table[]);
+extern void emit(tuple *tn, FILE *fp);
+
+extern char *enablers[MAXTYPES];
+extern assoc vartypes[];
+
+/* feh.h ends here */
--- /dev/null
+/*
+ * fiddle.c -- functions that implement the five INTERCAL operators
+ *
+ * We link these to the compiler, too, in order to do constant folding
+ *
+LICENSE TERMS
+ Copyright (C) 1996 Eric S. Raymond
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ */
+
+#include "fiddle.h"
+#include "sizes.h"
+
+unsigned int mingle(register unsigned int r, register unsigned int s)
+{
+ if (Base == 2) {
+ r = ((r & 0x0000ff00) << 8) | (r & 0x000000ff);
+ r = ((r & 0x00f000f0) << 4) | (r & 0x000f000f);
+ r = ((r & 0x0c0c0c0c) << 2) | (r & 0x03030303);
+ r = ((r & 0x22222222) << 1) | (r & 0x11111111);
+ s = ((s & 0x0000ff00) << 8) | (s & 0x000000ff);
+ s = ((s & 0x00f000f0) << 4) | (s & 0x000f000f);
+ s = ((s & 0x0c0c0c0c) << 2) | (s & 0x03030303);
+ s = ((s & 0x22222222) << 1) | (s & 0x11111111);
+ return (r << 1) | s;
+ }
+ else {
+ unsigned int result = 0, fac = 1;
+ int i;
+ for (i = 0 ; i < Small_digits ; i++) {
+ result += fac * (s % Base);
+ s /= Base;
+ fac *= Base;
+ result += fac * (r % Base);
+ r /= Base;
+ fac *= Base;
+ }
+ return result;
+ }
+}
+
+unsigned int iselect(register unsigned int r, register unsigned int s)
+{
+ if (Base == 2) {
+ register unsigned int i = 1, t = 0;
+ while (s) {
+ if (s & i) {
+ t |= r & i;
+ s ^= i;
+ i <<= 1;
+ }
+ else {
+ s >>= 1;
+ r >>= 1;
+ }
+ }
+ return(t);
+ }
+ else {
+ unsigned int j, result = 0, fac, digit, ofac = 1;
+ for (j = Base - 1 ; j > 0 ; j--) {
+ int i;
+ fac = 1;
+ for (i = 0; i < Large_digits ; i++) {
+ if ((s / fac) % Base == j) {
+ digit = (r / fac) % Base;
+ if (digit)
+ result += ofac * (digit > j ? digit : j);
+ ofac *= Base;
+ }
+ fac *= Base;
+ }
+ }
+ return result;
+ }
+}
+
+static unsigned int whirl(unsigned int len, unsigned int p, unsigned int n)
+{
+ unsigned int i, fac = 1, result = 0, d1, d2, dsave;
+ d1 = n % Base;
+ dsave = d1;
+ for (i = 1 ; i <= len ; i++) {
+ d2 = d1;
+ d1 = (i < len) ? (n /= Base, n % Base) : dsave;
+ if (d1 <= p)
+ result += fac * ((d2 < d1 || d2 > p) ? d1 : d2);
+ else
+ result += fac * ((d2 < d1 && d2 > p) ? d1 : d2);
+ fac *= Base;
+ }
+ return result;
+}
+
+unsigned int and16(unsigned int n)
+{
+ if (Base == 2) {
+ unsigned int m = (n >> 1);
+ if (n & 1)
+ m |= 0x8000;
+ return(m & n);
+ }
+ else {
+ return whirl(Small_digits,0,n);
+ }
+}
+
+unsigned int or16(unsigned int n)
+{
+ if (Base == 2) {
+ unsigned int m = (n >> 1);
+ if (n & 1)
+ m |= 0x8000;
+ return(m | n);
+ }
+ else {
+ return whirl(Small_digits,Base-1,n);
+ }
+}
+
+unsigned int whirl16(unsigned int p, unsigned int n)
+{
+ return whirl(Small_digits,p,n);
+}
+
+unsigned int and32(unsigned int n)
+{
+ if (Base == 2) {
+ unsigned int m = (n >> 1);
+ if (n & 1)
+ m |= 0x80000000;
+ return(m & n);
+ }
+ else {
+ return whirl(Large_digits,0,n);
+ }
+}
+
+unsigned int or32(unsigned int n)
+{
+ if (Base == 2) {
+ unsigned int m = (n >> 1);
+ if (n & 1)
+ m |= 0x80000000;
+ return(m | n);
+ }
+ else {
+ return whirl(Large_digits,Base-1,n);
+ }
+}
+
+unsigned int whirl32(unsigned int p, unsigned int n)
+{
+ return whirl(Large_digits,p,n);
+}
+
+unsigned int xor(unsigned int len, unsigned int n)
+{
+ unsigned int i, fac = 1, result = 0, d1, d2, dsave;
+ d1 = n % Base;
+ dsave = d1;
+ for (i = 1 ; i <= len ; i++) {
+ d2 = d1;
+ d1 = (i < len) ? (n /= Base, n % Base) : dsave;
+ result += fac * ((Base + d1 - d2) % Base);
+ fac *= Base;
+ }
+ return result;
+}
+
+unsigned int xor16(unsigned int n)
+{
+ if (Base == 2) {
+ unsigned int m = (n >> 1);
+ if (n & 1)
+ m |= 0x8000;
+ return(m ^ n);
+ }
+ else {
+ return xor(Small_digits,n);
+ }
+}
+
+unsigned int xor32(unsigned int n)
+{
+ if (Base == 2) {
+ unsigned int m = (n >> 1);
+ if (n & 1)
+ m |= 0x80000000;
+ return(m ^ n);
+ }
+ else {
+ return xor(Large_digits,n);
+ }
+}
+
+static unsigned int fin(unsigned int len, unsigned int n)
+{
+ unsigned int i, fac = 1, result = 0, d1, d2, dsave;
+ d1 = n % Base;
+ dsave = d1;
+ for (i = 1 ; i <= len ; i++) {
+ d2 = d1;
+ d1 = (i < len) ? (n /= Base, n % Base) : dsave;
+ result += fac * ((d1 + d2) % Base);
+ fac *= Base;
+ }
+ return result;
+}
+
+unsigned int fin16(unsigned int n)
+{
+ if (Base == 2) {
+ unsigned int m = (n >> 1);
+ if (n & 1)
+ m |= 0x8000;
+ return(m ^ n);
+ }
+ else {
+ return fin(Small_digits,n);
+ }
+}
+
+unsigned int fin32(unsigned int n)
+{
+ if (Base == 2) {
+ unsigned int m = (n >> 1);
+ if (n & 1)
+ m |= 0x80000000;
+ return(m ^ n);
+ }
+ else {
+ return fin(Large_digits,n);
+ }
+}
+
+/* fiddle.c */
--- /dev/null
+/* fiddle.h -- functions implementing intercal's operators */
+
+extern unsigned int mingle(register unsigned int r, register unsigned int s);
+extern unsigned int iselect(register unsigned int r, register unsigned int s);
+extern unsigned int and16(unsigned int n), or16(unsigned int n),
+ xor16(unsigned int n), fin16(unsigned int n);
+extern unsigned int whirl16(unsigned int p, unsigned int n);
+extern unsigned int and32(unsigned int n), or32(unsigned int n),
+ xor32(unsigned int n), fin32(unsigned int n);
+extern unsigned int whirl32(unsigned int p, unsigned int n);
+
+/* fiddle.h ends here */
--- /dev/null
+/* $A.c -- generated C-code file for INTERCAL program $A.i */
+
+/* This code is explicitly *not* GPLed. Use, abuse, and redistribute freely */
+
+#include <stdio.h>
+#include <stdlib.h>
+#include <time.h>
+
+#include <fiddle.h>
+#include <abcess.h>
+#include <lose.h>
+
+int lineno;
+
+static int abstained[$B]$C;
+$D
+$E
+
+int main(int argc, char *argv[])
+{
+ int skipto = 0;
+
+ parseargs(argc,argv);
+
+ /* set seed for random error generation */
+#ifdef USG
+ srand48(time((long *)0) + getpid());
+#else
+ srand(time((long *)0));
+#endif /* UNIX */
+
+ /* set up stash storage */
+ stashinit();
+
+ $F
+ /* degenerated code */
+$G
+ lose(E633, $J, (char *)0);
+
+$H
+ return 0;
+}
+
+/* Generated code for $A.i ends here */
--- /dev/null
+/* ick.h -- compilation types for intercal parser */
+
+/* Comment this out if your version of lex automatically supplies yylineno. */
+#define YYLINENO_BY_HAND
+
+/* Comment this out if your version of lex doesn't use yyrestart(). */
+#define USE_YYRESTART
+
+typedef int bool;
+#define TRUE 1
+#define FALSE 0
+
+#define ALLOC_CHUNK 256
+
+/*
+ * We choose this value for maximum number of possible variables on
+ * the theory that no human mind could grok a more complex INTERCAL
+ * program than this and still retain any vestige of sanity.
+#define MAXVARS 100
+ */
+
+/*
+ * Maximum supported statement types; should be equal to (COME_FROM - GETS + 1)
+ */
+#define MAXTYPES 17
+
+typedef struct node_t
+{
+ int opcode; /* operator or type code */
+ unsigned long constant; /* constant data attached */
+ int width; /* is this 32-bit data? */
+ struct node_t *lval, *rval; /* attached expression nodes */
+} node;
+
+typedef struct tuple_t
+{
+ unsigned int label; /* label # of this statement */
+ unsigned int comefrom; /* if NZ, a COME FROM touches this */
+ int exechance; /* chance of execution */
+ unsigned int type; /* statement type */
+ union
+ {
+ unsigned int target; /* for NEXT statements */
+ node *node; /* attached expression node(s) */
+ } u;
+ int lineno; /* source line for error messages */
+ bool sharedline; /* if NZ, two statements on a line */
+} tuple;
+
+/* this maps the `external' name of a variable to an internal array index */
+typedef struct
+{
+ int type;
+ int extindex;
+ int intindex;
+}
+atom;
+
+typedef struct
+{
+ int value;
+ char *name;
+}
+assoc;
+
+extern atom *oblist, *obdex;
+extern int obcount, nonespots, ntwospots, ntails, nhybrids;
+
+extern tuple *tuples;
+extern int tuplecount;
+
+extern char *enablers[MAXTYPES];
+extern assoc vartypes[];
+
+/* the lexical analyzer keeps copies of the source logical lines */
+extern char **textlines;
+extern int textlinecount;
+extern int yylineno;
+
+/* compilation options */
+extern bool compile_only; /* just compile into C, don't run the linker */
+extern bool nocompilerbug; /* set possibility of E774 to zero */
+extern int traditional; /* compile as INTERCAL-72 */
+extern int yydebug; /* print debugging information while parsing */
+
+extern int politesse;
+
+/* ick.h ends here */
--- /dev/null
+/*****************************************************************************
+
+NAME
+ ick.y -- grammar for the INTERCAL language
+
+DESCRIPTION
+ This YACC grammar parses the INTERCAL language by designed by Don R. Woods
+and James M. Lyon. There are two syntax extensions over the original
+INTERCAL-72 language; the COME FROM statement, and the prefixed forms of the
+WHIRL operator.
+
+LICENSE TERMS
+ Copyright (C) 1996 Eric S. Raymond
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+*****************************************************************************/
+
+%{
+#include <stdio.h>
+#include <stdlib.h>
+#include "sizes.h"
+#include "ick.h"
+#include "feh.h"
+#include "lose.h"
+
+extern int yyerror(char*);
+
+/* Intervene our first-stage lexer. */
+extern int lexer(void);
+#define yylex() lexer()
+
+static node *rlist; /* pointer to current right-hand node list */
+/*static node *llist;*/ /* pointer to current left-hand node list */
+static node *np; /* variable for building node lists */
+
+extern int stbeginline; /* line number of last seen preamble */
+static int thisline; /* line number of beginning of current statement */
+static tuple *splat(void);
+
+#define GETLINENO \
+ {if (stbeginline < 0) thisline = -stbeginline; \
+ else {thisline = stbeginline; stbeginline = 0;}}
+
+#define ACTION(x, nt, nn) \
+ {x = newtuple(); x->type = nt; x->lineno = thisline; x->u.node = nn;}
+#define TARGET(x, nt, nn) \
+ {x = newtuple(); x->type = nt; x->lineno = thisline; x->u.target = nn;}
+#define NEWFANGLED if (traditional) lose(E111,yylineno,(char*)NULL); else
+
+%}
+
+%start program
+
+%union
+{
+ int numval; /* a numeric value */
+ tuple *tuple; /* a code tuple */
+ node *node; /* an expression-tree node */
+}
+
+/*
+ * Don't change this statement token list gratuitously!
+ * Some code in feh.c depends on GETS being the least
+ * statement type and on the order of the ones following.
+ */
+%token GETS RESIZE NEXT FORGET RESUME STASH RETRIEVE IGNORE REMEMBER ABSTAIN
+%token REINSTATE DISABLE ENABLE GIVE_UP READ_OUT WRITE_IN COME_FROM
+
+%token DO PLEASE NOT MESH ONESPOT TWOSPOT TAIL HYBRID
+%token MINGLE SELECT SPARK EARS SUB BY BADCHAR
+
+%token <numval> NUMBER UNARY OHOHSEVEN GERUND LABEL
+%token <node> INTERSECTION
+
+/*
+ * These are not tokens returned by the lexer, but they are used as
+ * tokens elsewhere. We define them here to insure that the values
+ * will not conflict with the other tokens. It is important that
+ * WHIRL through WHIRL5 be a continuous sequence.
+ */
+%token SPLATTERED C_AND C_OR C_XOR C_NOT AND OR XOR FIN MESH32
+%token WHIRL WHIRL2 WHIRL3 WHIRL4 WHIRL5
+
+%type <node> expr varlist variable constant lvalue inlist outlist
+%type <node> subscr byexpr scalar array initem outitem sublist
+%type <node> unambig subscr1 sublist1 oparray osubscr osubscr1
+%type <tuple> perform
+%type <numval> please preftype
+
+%nonassoc HIGHPREC
+%nonassoc EARS SPARK
+
+%% /* beginning of rules section */
+
+/* A program description consists of a sequence of statements */
+program : /* EMPTY */
+ | program command
+ ;
+
+/*
+ * Each command consists of an optional label, followed by a preamble,
+ * followed by an optional probability, followed by the statement body.
+ * Negative exechance values indicate initial abstentions, and will be
+ * made positive before code is emitted.
+ */
+command : please perform
+ {$2->label = 0; $2->exechance = $1 * 100;}
+ | please OHOHSEVEN perform
+ {$3->label = 0; $3->exechance = $1 * $2;}
+ | LABEL please perform
+ {checklabel($1); $3->label = $1; $3->exechance = $2 * 100;}
+ | LABEL please OHOHSEVEN perform
+ {checklabel($1); $4->label = $1; $4->exechance = $2 * $3;}
+ | error
+ {lose(E017, yylineno, (char *)NULL);}
+ ;
+
+/* There are two forms of preamble returned by the lexer */
+please : DO {GETLINENO; $$ = 1;}
+ | DO NOT {GETLINENO; $$ = -1;}
+ ;
+
+/* Here's how to parse statement bodies */
+perform : lvalue GETS expr {ACTION($$, GETS, cons(GETS,$1,$3));}
+ | array GETS byexpr {ACTION($$, RESIZE, cons(RESIZE,$1,$3));}
+ | LABEL NEXT {TARGET($$, NEXT, $1);}
+ | FORGET expr {ACTION($$, FORGET, $2);}
+ | RESUME expr {ACTION($$, RESUME, $2);}
+ | STASH varlist {ACTION($$, STASH, rlist);}
+ | RETRIEVE varlist {ACTION($$, RETRIEVE, rlist);}
+ | IGNORE varlist {ACTION($$, IGNORE, rlist);}
+ | REMEMBER varlist {ACTION($$, REMEMBER, rlist);}
+ | ABSTAIN LABEL {stbeginline=0; TARGET($$, ABSTAIN, $2);}
+ | ABSTAIN gerunds {ACTION($$, DISABLE, rlist);}
+ | REINSTATE LABEL {stbeginline=0; TARGET($$, REINSTATE, $2);}
+ | REINSTATE gerunds {ACTION($$, ENABLE, rlist);}
+ | WRITE_IN inlist {ACTION($$, WRITE_IN, $2);}
+ | READ_OUT outlist {ACTION($$, READ_OUT, $2);}
+ | GIVE_UP {ACTION($$, GIVE_UP, 0);}
+ | COME_FROM LABEL {NEWFANGLED {TARGET($$,COME_FROM,$2)}}
+ | BADCHAR {yyclearin; $$ = splat();}
+ | error {yyclearin; $$ = splat();}
+ ;
+
+/* gerund lists are used by ABSTAIN and REINSTATE */
+gerunds : GERUND
+ {rlist = np = newnode(); np->constant = $1;}
+ | gerunds INTERSECTION GERUND
+ {
+ np->rval = newnode();
+ np = np->rval;
+ np->constant = $3;
+ }
+ ;
+
+/* OK, here's what a variable reference looks like */
+variable: scalar | array;
+
+lvalue : scalar | subscr;
+
+scalar : ONESPOT NUMBER
+ {
+ $$ = newnode();
+ $$->opcode = ONESPOT;
+ $$->constant = intern(ONESPOT, $2);
+ }
+ | TWOSPOT NUMBER
+ {
+ $$ = newnode();
+ $$->opcode = TWOSPOT;
+ $$->constant = intern(TWOSPOT, $2);
+ }
+ ;
+
+array : TAIL NUMBER
+ {
+ $$ = newnode();
+ $$->opcode = TAIL;
+ $$->constant = intern(TAIL, $2);
+ }
+ | HYBRID NUMBER
+ {
+ $$ = newnode();
+ $$->opcode = HYBRID;
+ $$->constant = intern(HYBRID, $2);
+ }
+ ;
+
+/* Array with unary operator is a special intermediate case; these
+ nodes will be rearranged when the subscript list is added */
+oparray : TAIL UNARY NUMBER
+ {
+ $$ = newnode();
+ $$->opcode = $2;
+ $$->rval = newnode();
+ $$->rval->opcode = TAIL;
+ $$->rval->constant = intern(TAIL, $3);
+ }
+ | HYBRID UNARY NUMBER
+ {
+ $$ = newnode();
+ $$->opcode = $2;
+ $$->rval = newnode();
+ $$->rval->opcode = HYBRID;
+ $$->rval->constant = intern(HYBRID, $3);
+ }
+ ;
+
+/* And a constant looks like this */
+constant: MESH NUMBER
+ {
+ /* enforce the 16-bit constant constraint */
+ if ((unsigned int)$2 > Max_small)
+ lose(E017, yylineno, (char *)NULL);
+ $$ = newnode();
+ $$->opcode = MESH;
+ $$->constant = $2;
+ }
+ ;
+
+/* variable lists are used in STASH, RETRIEVE, IGNORE, REMEMBER */
+varlist : variable {rlist = np = $1;}
+ | varlist INTERSECTION variable {np = np->rval = $3;
+ /* newnode(); */ }
+ ;
+
+/* scalars and subscript exprs are permitted in WRITE IN lists */
+/* new: arrays are also permitted to allow for bitwise I/0 */
+initem : scalar | subscr | array;
+inlist : initem INTERSECTION inlist {$$=cons(INTERSECTION,$1,$3);}
+ | initem {$$=cons(INTERSECTION,$1,0);}
+ ;
+
+/* scalars, subscript exprs & constants are permitted in READ OUT lists */
+/* new: arrays are also permitted to allow for bitwise I/0 */
+outitem : scalar | subscr | constant | array;
+outlist : outitem INTERSECTION outlist {$$=cons(INTERSECTION,$1,$3);}
+ | outitem {$$=cons(INTERSECTION,$1,0);}
+ ;
+
+/* Now the gnarly part -- expression syntax */
+
+/* Support array dimension assignment */
+byexpr : expr BY byexpr {$$ = cons(BY, $1, $3);}
+ | expr {$$ = cons(BY, $1, 0);}
+ ;
+
+/* Support array subscripts (as lvalues) */
+subscr : subscr1 {$$ = $1;}
+ | array SUB sublist {$$ = cons(SUB, $1, $3);}
+ ;
+subscr1 : array SUB sublist1 {$$ = cons(SUB, $1, $3);}
+ ;
+sublist : unambig sublist {$$ = cons(INTERSECTION, $1, $2);}
+ | unambig sublist1 {$$ = cons(INTERSECTION, $1, $2);}
+ ;
+sublist1: subscr1 {$$ = cons(INTERSECTION, $1, 0);}
+ | osubscr1 {$$ = cons(INTERSECTION, $1, 0);}
+ | unambig %prec HIGHPREC {$$ = cons(INTERSECTION, $1, 0);}
+ ;
+
+/* Unary operators with arrays act like arrays only in expressions */
+osubscr : osubscr1 {$$ = $1;}
+ | oparray SUB sublist
+ {$$ = $1; $$->rval = cons(SUB, $$->rval, $3);}
+ ;
+osubscr1: oparray SUB sublist1
+ {$$ = $1; $$->rval = cons(SUB, $$->rval, $3);}
+ ;
+
+/* here goes the general expression syntax */
+expr : unambig {$$ = $1;}
+ | unambig SELECT unambig {$$ = cons(SELECT, $1, $3);}
+ | unambig SELECT subscr {$$ = cons(SELECT, $1, $3);}
+ | unambig SELECT osubscr {$$ = cons(SELECT, $1, $3);}
+ | unambig MINGLE unambig {$$ = cons(MINGLE, $1, $3);}
+ | unambig MINGLE subscr {$$ = cons(MINGLE, $1, $3);}
+ | unambig MINGLE osubscr {$$ = cons(MINGLE, $1, $3);}
+ | subscr {$$ = $1;}
+ | osubscr {$$ = $1;}
+ ;
+
+preftype: MESH {$$=MESH; } | ONESPOT {$$=ONESPOT;} | TWOSPOT {$$=TWOSPOT;};
+
+unambig : variable {$$ = $1;}
+ | constant {$$ = $1;}
+
+ /* deal with the bizarre unary-op syntax */
+ | preftype UNARY NUMBER
+ {
+ $$ = newnode();
+ $$->opcode = $2;
+ $$->rval = newnode();
+ $$->rval->opcode = $1;
+ if($1 == MESH) {
+ /* enforce the 16-bit constant constraint */
+ if ((unsigned int)$3 > Max_small)
+ lose(E017, yylineno, (char *)NULL);
+ $$->rval->constant = $3;
+ }
+ else {
+ $$->rval->constant = intern($1, $3);
+ }
+ }
+
+ /* Now deal with the screwy unary-op interaction with grouping */
+ | SPARK UNARY expr SPARK
+ {
+ $$ = newnode();
+ $$->opcode = $2;
+ $$->rval = $3;
+ }
+ | EARS UNARY expr EARS
+ {
+ $$ = newnode();
+ $$->opcode = $2;
+ $$->rval = $3;
+ }
+
+ | SPARK expr SPARK {$$ = $2;}
+ | EARS expr EARS {$$ = $2;}
+ ;
+
+%%
+
+static tuple *splat(void)
+/* try to recover from an invalid statement. */
+{
+ tuple *sp;
+ int tok, i;
+ extern bool re_send_token;
+
+ /*
+ * The idea
+ * here is to skip to the next DO, PLEASE or label, then unget that token.
+ * which we can do with a tricky flag on the lexer (re_send_token).
+ */
+
+ /* fprintf(stderr,"attempting to splat at line %d....\n",yylineno); */
+ for(i = 0,re_send_token = FALSE;;i++) {
+ tok = lexer();
+ if (!tok)
+ {
+ re_send_token = TRUE;
+ tok = ' '; /* scanner must not see a NUL */
+ break;
+ }
+ else if (tok == DO || tok == PLEASE || tok == LABEL) {
+ re_send_token = TRUE;
+ break;
+ }
+ }
+ /*
+ fprintf(stderr,"found %d on line %d after %d other tokens.\n",
+ tok,yylineno,i);
+ */
+
+ /* generate a placeholder tuple for the text line */
+ TARGET(sp, SPLATTERED, 0);
+
+ return(sp);
+}
+
+/* ick.y ends here */
+++ /dev/null
-Begin3
-Title: intercal
-Version: 0.21
-Entered-date: 30JUL2002
-Description: An implementation of the language INTERCAL, legendary for
- its perversity and horribleness (this version adds COME FROM
- for extra flavor). Comes with language manual and examples
- including possibly the entire extant body of INTERCAL code.
- Now supports i18n and l14n (to Ancient Roman locale only)
-Keywords: language, compiler, retrocomputing, geek humor
-Author: esr@thyrsus.com (Eric S. Raymond)
-Maintained-by: esr@thyrsus.com (Eric S. Raymond)
-Primary-site: http://www.tuxedo.org/~esr/intercal/
- 167K intercal-0.21.tar.gz
-Platforms: All
-Copying-policy: GPL
-End
-
-
--- /dev/null
+Name: intercal
+Version: 0.22
+Release: 1
+URL: http://www.catb.org/~esr/intercal/
+Source: intercal-0.22.tar.gz
+License: GPL
+Group: Development/Languages
+Summary: the language that kills the weak and drives mad the strong
+
+%description
+An implementation of the language INTERCAL, legendary for
+its perversity and horribleness (this version adds COME FROM
+for extra flavor). Comes with language manual and examples
+including possibly the entire extant body of INTERCAL code.
+Now supports i18n and l14n (to Ancient Roman locale only)
+Now with fix patch by Donald Knuth.
+
+%prep
+%setup -q
+
+%build
+configure --prefix=/usr
+make
+
+%install
+rm -fr /usr/share/intercal-0.22/*
+make install
+
+%files
+/usr/bin/ick
+/usr/lib/libick.a
+/usr/include/intercal-0.22/lose.h
+/usr/include/intercal-0.22/abcess.h
+/usr/include/intercal-0.22/fiddle.h
+/usr/share/intercal-0.22/ick-wrap.c
+/usr/share/intercal-0.22/
+%doc README BUGS NEWS
--- /dev/null
+%{
+/*
+ * NAME
+ * lexer.l -- source for the C-INTERCAL lexical analyzer.
+ *
+LICENSE TERMS
+ Copyright (C) 1996 Eric S. Raymond
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+*/
+#include <stdio.h>
+#include <stdlib.h>
+#include <ctype.h>
+#include <string.h>
+#include <memory.h>
+#include "ick.h"
+#include "y.tab.h"
+#include "lose.h"
+
+#define YY_NO_UNPUT
+
+#ifndef yywrap
+static int yywrap(void)
+{
+ return 1;
+}
+#endif /* yywrap */
+
+#ifdef YYLINENO_BY_HAND
+int yylineno = 1;
+#endif /* YYLINENO_BY_HAND */
+
+#ifdef MAIN
+YYSTYPE yylval;
+#endif /* MAIN */
+
+char **textlines = NULL;
+int textlinecount = 0;
+int politesse = 0;
+int stbeginline = 0;
+
+#ifdef FLEX_SCANNER
+static char linebuf[YY_BUF_SIZE];
+#else /* FLEX_SCANNER */
+static char linebuf[YYLMAX];
+#endif /* FLEX_SCANNER */
+
+static char *lineptr = linebuf;
+
+bool re_send_token = FALSE;
+
+int lexer(void);
+static int myatoi(char *text);
+
+#define SETLINENO \
+ {if (stbeginline == 0) stbeginline = yylineno; \
+ else if (stbeginline < 0) stbeginline = 0;}
+
+/*
+ * The spectacular ugliness of INTERCAL syntax requires that the lexical
+ * analyzer have two levels. One, embedded in the getc() function, handles
+ * logical-line continuation and the ! abbrev, and stashes each logical
+ * line away in a buffer accessible to the code generator (this is necessary
+ * for the * construct to be interpreted correctly). The upper level is
+ * generated by lex(1) and does normal tokenizing.
+ */
+
+#undef getc
+int getc(FILE *fp)
+{
+ extern FILE* yyin;
+
+ static bool bangflag = FALSE;
+ static bool backflag = FALSE;
+
+ if (bangflag)
+ {
+ bangflag = FALSE;
+ /* *lineptr++ = '!'; */
+ return('.');
+ }
+ else if (backflag) /* converting ctrl-H (backspace) to two chars "^H" */
+ {
+ backflag = FALSE;
+ /* *lineptr++ = '\b'; */
+ return('H');
+ }
+ else
+ {
+ int c = fgetc(fp);
+
+ if (feof(yyin))
+ {
+ *lineptr = '\0';
+ return(EOF);
+ }
+#ifdef BACKSLASH_CONTINUATION
+ else if (c == '\\')
+ {
+ do {
+ c = fgetc(fp);
+#ifdef YYLINENO_BY_HAND
+ if( c == '\n' ) yylineno++;
+#endif /* YYLINENO_BY_HAND */
+ } while
+ (c != '\\' && isspace(c));
+ }
+#endif /* BACKSLASH_CONTINUATION */
+ if (c == '!')
+ {
+ *lineptr++ = '!';
+ bangflag = TRUE;
+ return(c = '\'');
+ }
+ else if (c == '\b') /* convert ctrl-H (backspace) to
+ two chars "^" and "H" so lex can take it */
+ {
+ *lineptr++ = '\b';
+ backflag = TRUE;
+ return(c = '^');
+ }
+ else if (c == '\n')
+ {
+ *lineptr = '\0';
+ lineptr = linebuf;
+ if (yylineno >= textlinecount)
+ {
+ textlinecount += ALLOC_CHUNK;
+ if (textlines)
+ textlines = realloc(textlines,
+ textlinecount * sizeof(char*));
+ else
+ textlines = malloc(textlinecount * sizeof(char*));
+ if (!textlines)
+ lose(E666, yylineno, (char *)NULL);
+ }
+ textlines[yylineno] = malloc(1 + strlen(linebuf));
+ if (!textlines[yylineno])
+ lose(E666, yylineno, (char *)NULL);
+ strcpy(textlines[yylineno], linebuf);
+#ifdef YYLINENO_BY_HAND
+ yylineno++;
+#endif /* YYLINENO_BY_HAND */
+ return('\n');
+ }
+ else
+ {
+#ifdef ACCEPT_LOWERCASE
+ if (islower(c))
+ c = toupper(c);
+#endif /* ACCEPT_LOWERCASE */
+ return(*lineptr++ = c);
+ }
+ }
+}
+
+/* replace YY_INPUT so that it uses our getc function. */
+#undef YY_INPUT
+#define YY_INPUT(buf,result,max_size) \
+ { \
+ int c = getc(yyin); \
+ if (c == EOF) { \
+ if (ferror(yyin)) \
+ YY_FATAL_ERROR("input in flex scanner failed"); \
+ result = YY_NULL; \
+ } else { \
+ buf[0] = c; \
+ result = 1; \
+ } \
+ }
+
+%}
+
+W [\ \t\n]*
+D [0-9][\ \t\n0-9]*
+
+%%
+
+{D} {yylval.numval = myatoi(yytext); return(NUMBER);}
+\. {return(ONESPOT);}
+\: {return(TWOSPOT);}
+\, {return(TAIL);}
+\; {return(HYBRID);}
+\# {return(MESH);}
+
+\$ |
+\xA2 |
+\xA3 |
+\xA4 |
+\xC2\xA2 |
+\xC2\xA3 |
+\xC2\xA4 |
+\xE2\x82\xA0 |
+\xE2\x82\xA1 |
+\xE2\x82\xA2 |
+\xE2\x82\xA3 |
+\xE2\x82\xA4 |
+\xE2\x82\xA5 |
+\xE2\x82\xA6 |
+\xE2\x82\xA7 |
+\xE2\x82\xA8 |
+\xE2\x82\xA9 |
+\xE2\x82\xAA |
+\xE2\x82\xAB |
+\xE2\x82\xAC |
+\xE0\xA7\xB2 |
+\xE0\xA7\xB3 |
+\xE0\xB8\xBF {return(MINGLE);}
+
+\~ {return(SELECT);}
+
+\& {yylval.numval = AND; return(UNARY);}
+V {yylval.numval = OR; return(UNARY);}
+"V^H-" |
+\xE2\x88\x80 |
+\? {yylval.numval = XOR; return(UNARY);}
+\^ {yylval.numval = FIN; return(UNARY);}
+@ {yylval.numval = WHIRL; return(UNARY);}
+[2-5]{W}@ {yylval.numval = WHIRL + myatoi(yytext) - 1; return(UNARY);}
+
+\' {return(SPARK);}
+\" {return(EARS);}
+
+\({W}{D}\) {SETLINENO; yylval.numval = myatoi(yytext); return(LABEL);}
+
+DO {SETLINENO; return(DO);}
+FAC {SETLINENO; return(DO);}
+PLEASE {SETLINENO; politesse++; return(DO);}
+PLACET {SETLINENO; politesse++; return(DO);}
+PLEASE{W}DO {SETLINENO; politesse++; return(DO);}
+PLACET{W}FACERE {SETLINENO; politesse++; return(DO);}
+NOT {return(NOT);}
+N\'T {return(NOT);}
+NON {return(NOT);}
+
+\%{W}{D} {yylval.numval = myatoi(yytext);
+ if (yylval.numval && yylval.numval < 100)
+ return(OHOHSEVEN);
+ else
+ lose(E017, yylineno, (char *)NULL);}
+SUB {return(SUB);}
+MULTIPLICATUS{W}A |
+BY {return(BY);}
+
+\<- {return(GETS);}
+CALCULANDUM |
+CALCULATING {yylval.numval = GETS; return(GERUND);}
+
+DEINDE |
+NEXT {stbeginline = 0; return(NEXT);}
+PROXIMANDUM |
+NEXTING {yylval.numval = NEXT; return(GERUND);}
+ALIENERE |
+FORGET {return(FORGET);}
+ALIENENDUM |
+FORGETTING {yylval.numval = FORGET; return(GERUND);}
+RECOLERE |
+RESUME {return(RESUME);}
+RECOLERENDUM |
+RESUMING {yylval.numval = RESUME; return(GERUND);}
+EXUERE |
+STASH {return(STASH);}
+EXUENDUM |
+STASHING {yylval.numval = STASH; return(GERUND);}
+INUERE |
+RETRIEVE {return(RETRIEVE);}
+INUENDUM |
+RETRIEVING {yylval.numval = RETRIEVE; return(GERUND);}
+DISSIMULARE |
+IGNORE {return(IGNORE);}
+DISSIMULANDUM |
+IGNORING {yylval.numval = IGNORE; return(GERUND);}
+MEMINISSE |
+REMEMBER {return(REMEMBER);}
+MEMINISSENDUM |
+REMEMBERING {yylval.numval = REMEMBER; return(GERUND);}
+ABSTINERE{W}A |
+ABSTAIN{W}FROM {return(ABSTAIN);}
+ABSTINENDUM |
+ABSTAINING {yylval.numval = ABSTAIN; return(GERUND);}
+REINSTARE |
+REINSTATE {return(REINSTATE);}
+REINSTATANDUM |
+REINSTATING {yylval.numval = REINSTATE; return(GERUND);}
+LEGERE{W}EX |
+READ{W}OUT {return(READ_OUT);}
+LEGENDUM |
+READING{W}OUT {yylval.numval = READ_OUT; return(GERUND);}
+SCRIBERE{W}IN |
+WRITE{W}IN {return(WRITE_IN);}
+SCRIBENDUM |
+WRITING{W}IN {yylval.numval = WRITE_IN; return(GERUND);}
+ADVENIRE{W}DE |
+COME{W}FROM {stbeginline = -stbeginline; return(COME_FROM);}
+ADVENENDUM |
+COMING{W}FROM {yylval.numval = COME_FROM; return(GERUND);}
+CONCEDERE |
+DESPERARE |
+GIVE{W}UP {return(GIVE_UP);}
+
+\+ {return(INTERSECTION);}
+
+{W} ;
+. {yylval.numval = yytext[0]; return(BADCHAR);}
+
+
+%%
+
+int lexer(void)
+{
+ static int tok = BADCHAR;
+
+ if (re_send_token)
+ re_send_token = FALSE;
+ else
+ {
+ tok = yylex();
+#ifdef YYDEBUG
+ if (yydebug)
+ (void) fprintf(stdout, "yylex: returning token %d\n", tok);
+#endif /* YYDEBUG */
+ }
+
+#ifdef YYDEBUG
+ if (yydebug)
+ (void) fprintf(stdout, "lexer: returning token %d\n", tok);
+#endif /* YYDEBUG */
+ return(tok);
+}
+
+static int myatoi(char *text)
+{
+#define MAXTEXT 100
+ static char buf[MAXTEXT];
+ register int i;
+
+ for(buf[i = 0] = '\0';*text && i < MAXTEXT;text++) {
+ if(isdigit(*text)) {
+ buf[i++] = *text;
+ }
+ }
+ buf[i] = '\0';
+ return atoi(buf);
+}
+
+void yyerror(char *errtype)
+{
+#ifdef MAIN
+ (void) printf("lextest: lexer error: %s.\n", errtype);
+#else /* MAIN */
+ /* lose(E017, yylineno, (char *)NULL); */
+ (void) errtype;
+#endif /* MAIN */
+}
+
+#ifdef MAIN
+int main(void)
+{
+ int t;
+
+ while ((t = yylex()) > 0)
+ {
+ (void) printf("%03d %09d\n", t, yylval.numval);
+ yylval.numval = 0;
+ }
+ return 0;
+}
+#endif /* MAIN */
--- /dev/null
+/*
+ *
+ * NAME
+ * lose.c -- report INTERCAL compile- or run-time error
+ *
+LICENSE TERMS
+ Copyright (C) 1996 Eric S. Raymond
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ */
+/*LINTLIBRARY*/
+#include <stdio.h>
+#include <stdlib.h>
+#include "lose.h"
+
+void lose(char *m, int n, char *s)
+{
+ (void) fprintf(stderr,
+ "ICL%c%c%cI\t",
+ m[0], m[1], m[2]);
+ if (s)
+ (void) fprintf(stderr, m + 4, s, n);
+ else
+ (void) fprintf(stderr, m + 4, n);
+ (void) fprintf(stderr, " CORRECT SOURCE AND RESUBNIT\n");
+ exit(atoi(m));
+}
+
+/* lose.c ends here */
+
+
--- /dev/null
+/* lose.h --- error message strings */
+
+/*
+ * Note: these error message texts, with one exception, are direct from
+ * the Princeton compiler (INTERCAL-72) sources (transmitted by Don Woods).
+ * The one exception is E632, which in INTERCAL-72 had the error message
+ * PROGRAM ATTEMPTED TO EXIT WITHOUT ERROR MESSAGE
+ * ESR's "THE NEXT STACK HAS RUPTURED!..." has been retained on the grounds
+ * that it is more obscure and much funnier. For context, find a copy of
+ * Joe Haldeman's SF short story "A !Tangled Web", first published in
+ * Analog magazine in September 1981 and later anthologized in the author's
+ * "Infinite Dreams" (Ace 1985).
+ */
+/* An undecodable statement has been encountered in the course of execution. */
+#define E000 "000 %s\n\
+ ON THE WAY TO %d\n"
+/* An expression contains a syntax error. */
+#define E017 "017 DO YOU EXPECT ME TO FIGURE THIS OUT?\n\
+ ON THE WAY TO %d\n"
+/* Improper use has been made of statement identifiers. */
+#define E079 "079 PROGRAMMER IS INSUFFICIENTLY POLITE\n\
+ ON THE WAY TO %d\n"
+/* Improper use has been made of statement identifiers. */
+#define E099 "099 PROGRAMMER IS OVERLY POLITE\n\
+ ON THE WAY TO %d\n"
+/* Program has attempted 80 levels of NEXTing */
+#define E123 "123 PROGRAM HAS DISAPPEARED INTO THE BLACK LAGOON\n\
+ ON THE WAY TO %d\n"
+/* Program has attempted to transfer to a non-existent line label */
+#define E129 "129 PROGRAM HAS GOTTEN LOST\n\
+ ON THE WAY TO WHO KNOWS WHERE\n"
+/* An ABSTAIN or REINSTATE statement references a non-existent line label */
+#define E139 "139 I WASN'T PLANNING TO GO THERE ANYWAY\n\
+ ON THE WAY TO %d\n"
+/* A line label has been multiply defined. */
+#define E182 "182 YOU MUST LIKE THIS LABEL A LOT!\n\
+ ON THE WAY TO %d\n"
+/* An invalid line label has been encountered. */
+#define E197 "197 SO! 65535 LABELS AREN'T ENOUGH FOR YOU?\n\
+ ON THE WAY TO %d\n"
+/* An expression involves an unidentified variable. */
+#define E200 "200 NOTHING VENTURED, NOTHING GAINED\n\
+ ON THE WAY TO %d\n"
+/* An attempt has been made to give an array a dimension of zero. */
+#define E240 "240 ERROR HANDLER PRINTED SNIDE REMARK\n\
+ ON THE WAY TO %d\n"
+/* Invalid dimensioning information was supplied
+ * in defining or using an array. */
+#define E241 "241 VARIABLES MAY NOT BE STORED IN WEST HYPERSPACE\n\
+ ON THE WAY TO %d\n"
+/* A 32-bit value has been assigned to a 16-bit variable. */
+#define E275 "275 DON'T BYTE OFF MORE THAN YOU CAN CHEW\n\
+ ON THE WAY TO %d\n"
+/* A retrieval has been attempted for an unSTASHed value. */
+#define E436 "436 THROW STICK BEFORE RETRIEVING!\n\
+ ON THE WAY TO %d\n"
+/* A WRITE IN statement or interleave ($) operation
+ * has produced value requiring over 32 bits to represent. */
+#define E533 "533 YOU WANT MAYBE WE SHOULD IMPLEMENT 64-BIT VARIABLES?\n\
+ ON THE WAY TO %d\n"
+/* Insufficient data. (raised by reading past EOF) */
+#define E562 "562 I DO NOT COMPUTE\n\
+ ON THE WAY TO %d\n"
+/* Input data is invalid. */
+#define E579 "579 WHAT BASE AND/OR LANGUAGE INCLUDES %s?\n\
+ ON THE WAY TO %d\n"
+/* The expression of a RESUME statement evaluated to #0. */
+#define E621 "621 ERROR TYPE 621 ENCOUNTERED\n\
+ ON THE WAY TO %d\n"
+/* Program execution terminated via a RESUME statement instead of GIVE UP. */
+#define E632 "632 THE NEXT STACK RUPTURES. ALL DIE. OH, THE EMBARRASSMENT!\n\
+ ON THE WAY TO %d\n"
+/* Execution has passed beyond the last statement of the program. */
+#define E633 "633 PROGRAM FELL OFF THE EDGE\n\
+ ON THE WAY TO THE NEW WORLD\n"
+/* A compiler error has occurred (see section 8.1). */
+#define E774 "774 RANDOM COMPILER BUG\n\
+ ON THE WAY TO %d\n"
+/* An unexplainable compiler error has occurred (see J. Lyon or D. Woods). */
+#define E778 "778 UNEXPLAINED COMPILER BUG\n\
+ ON THE WAY TO %d\n"
+
+/*
+ * These errors are unique to C-INTERCAL.
+ */
+/* You tried to use a C-INTERCAL extension with the `traditional' flag on */
+#define E111 "111 COMMUNIST PLOT DETECTED, COMPILER IS SUICIDING\n\
+ ON THE WAY TO %d\n"
+/* Cannot find the magically included system library */
+#define E127 "127 SAYING 'ABRACADABRA' WITHOUT A MAGIC WAND WON'T DO YOU ANY GOOD\n\
+ ON THE WAY TO THE CLOSET\n"
+/* Out of stash space */
+#define E222 "222 BUMMER, DUDE!\n\
+ ON THE WAY TO %d\n"
+/* Too many variables. */
+#define E333 "333 YOU CAN'T HAVE EVERYTHING, WHERE WOULD YOU PUT IT?\n\
+ ON THE WAY TO %d\n"
+/* A COME FROM statement references a non-existent line label. */
+#define E444 "444 IT CAME FROM BEYOND SPACE\n\
+ ON THE WAY TO %d\n"
+/* More than one COME FROM references the same label. */
+#define E555 "555 FLOW DIAGRAM IS EXCESSIVELY CONNECTED\n\
+ ON THE WAY TO %d\n"
+/* Too many source lines. */
+#define E666 "666 COMPILER HAS INDIGESTION\n\
+ ON THE WAY TO %d\n"
+/* No such source file. */
+#define E777 "777 A SOURCE IS A SOURCE, OF COURSE, OF COURSE\n\
+ ON THE WAY TO %d\n"
+/* Can't open C output file */
+#define E888 "888 I HAVE NO FILE AND I MUST SCREAM\n\
+ ON THE WAY TO %d\n"
+/* Can't open C skeleton file. */
+#define E999 "999 NO SKELETON IN MY CLOSET, WOE IS ME!\n\
+ ON THE WAY TO %d\n"
+/* Source file name with invalid extension (use .i or .[3-7]i). */
+#define E998 "998 EXCUSE ME,\n\
+ YOU MUST HAVE ME CONFUSED WITH SOME OTHER COMPILER\n"
+/* Illegal possession of a controlled unary operator. */
+#define E997 "997 ILLEGAL POSSESSION OF A CONTROLLED UNARY OPERATOR.\n\
+ ON THE WAY TO %d\n"
+
+extern int lineno;
+
+extern void lose(char *m, int n, char *s);
+
+/* lose.h ends here */
--- /dev/null
+/*
+ * numeral.c -- internationalization support for INTERCAL input.
+ *
+ * After release 0.5, I wrote:
+ *
+ * 2. (ESR) Input format internationalization -- allow WRITE IN input digits in
+ * major languages such as Nahuatl, Tagalog, Sanskrit, and Basque.
+ *
+ * The twisted loons in the alt.folklore.computers crowd loved this
+ * idea, and I actually got sent digit lists for Nahuatl, Tagalog,
+ * Sanskrit, and Basque -- also, Kwakiutl, Georgian, Ojibwe. Albanian,
+ * and Volap\"uk. I've left out Albanian (didn't want to keep track
+ * of the dipthong diacritical) and Ojibwe (no zero digit). So:
+ * Nahuatl, Tagalog, Sanskrit, Basque, Georgian, Kwakiutl, and
+ * Volap\"uk are now supported in addition to English.
+ *
+ * As of release 0.18, Volap\"uk digits can be entered in either traditional
+ * Tex format, Latin-1, or UTF-8. Latin is also now a supported language,
+ * to fulfill the requirement for Ancient Roman localization.
+ *
+LICENSE TERMS
+ Copyright (C) 1996 Eric S. Raymond
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+ */
+
+typedef struct
+{
+ char *name;
+ int value;
+}
+numeral;
+
+static numeral numerals[] =
+{
+/* English */
+ { "OH", 0 },
+ { "ZERO", 0 },
+ { "ONE", 1 },
+ { "TWO", 2 },
+ { "THREE", 3 },
+ { "FOUR", 4 },
+ { "FIVE", 5 },
+ { "SIX", 6 },
+ { "SEVEN", 7 },
+ { "EIGHT", 8 },
+ { "NINE", 9 },
+ { "NINER", 9 }, /* For all you junior birdmen */
+/* Sanskrit */
+ { "SUTYA", 0 }, /* Retroflex s, pronounced halfway to sh */
+ { "SHUTYA", 0 },
+ { "EKA", 1 },
+ { "DVI", 2 },
+ { "TRI", 3 },
+ { "CHATUR", 4 },
+ { "PANCHAN", 5 },
+ { "SHASH", 6 },
+ { "SAPTAM", 7 },
+ { "ASHTAN", 8 },
+ { "NAVAN", 9 },
+/* Basque */
+ { "ZEROA", 0 },
+ { "BAT", 1 },
+ { "BI", 2 },
+ { "HIRO", 3 },
+ { "LAU", 4 },
+ { "BORTZ", 5 },
+ { "SEI", 6 },
+ { "ZAZPI", 7 },
+ { "ZORTZI", 8 },
+ { "BEDERATZI", 9 },
+/* Tagalog */
+ { "WALA", 0 },
+ { "ISA", 1 },
+ { "DALAWA", 2 },
+ { "TATLO", 3 },
+ { "APAT", 4 },
+ { "LIMA", 5 },
+ { "ANIM", 6 },
+ { "PITO", 7 },
+ { "WALO", 8 },
+ { "SIYAM", 9 },
+/* Classical Nahuatl */
+ { "AHTLE", 0 }, /* Actually `nothing'; no separate zero word is known */
+ { "CE", 1 },
+ { "OME", 2 },
+ { "IEI", 3 },
+ { "NAUI", 4 },
+ { "NACUILI", 5 },
+ { "CHIQUACE", 6 },
+ { "CHICOME", 7 },
+ { "CHICUE", 8 },
+ { "CHICUNAUI", 9 },
+/* Georgian */
+ { "NULI", 0 },
+ { "ERTI", 1 },
+ { "ORI", 2 },
+ { "SAMI", 3 },
+ { "OTXI", 4 },
+ { "XUTI", 5 },
+ { "EKSVI", 6 },
+ { "SHVIDI", 7 },
+ { "RVA", 8 },
+ { "CXRA", 9 },
+/* Kwakiutl (technically, Kwak'wala) */
+ { "KE'YOS", 0 }, /* Actually `nothing'; no separate zero word is known */
+ { "'NEM", 1 },
+ { "MAL'H", 2 },
+ { "YUDEXW", 3 },
+ { "MU", 4 },
+ { "SEK'A", 5 },
+ { "Q'ETL'A", 6 },
+ { "ETLEBU", 7 },
+ { "MALHGWENALH", 8 },
+ { "'NA'NE'MA", 9 },
+/* Volap\"uk */
+ { "NOS", 0 },
+ { "BAL", 1 },
+ { "TEL", 2 },
+ { "KIL", 3 },
+ { "FOL", 4 },
+ { "LUL", 5 },
+ { "M\\\"AL", 6 },
+ { "M\xC4L", 6 }, /* Latin-1 support */
+ { "M\xA3\xA4L", 6 }, /* UTF-8 support */
+ { "VEL", 7 },
+ { "J\\\"OL", 8 },
+ { "J\xD6L", 8 }, /* Latin-1 support */
+ { "J\xA3\x96L", 8 }, /* UTF-8 support */
+ { "Z\\\"UL", 9 },
+ { "Z\xDCL", 9 }, /* Latin-1 support */
+ { "Z\xA3\x9CL", 9 }, /* UTF-8 support */
+/* Latin localization */
+ { "NIL", 0 },
+ { "NIHIL", 0 },
+ { "UNUS", 1 },
+ { "UNA", 1 },
+ { "UNUM", 1 },
+ { "DUO", 2 },
+ { "DUAE", 2 },
+ { "TRES", 3 },
+ { "QUATTUOR", 4 },
+ { "QUATUOR", 4 },
+ { "QUINQUE", 5 },
+ { "SEX", 6 },
+ { "SEPTEM", 7 },
+ { "OCTO", 8 },
+ { "NOVEM", 9 },
+};
+
+/* numeral.c ends here */
--- /dev/null
+/****************************************************************************
+
+NAME
+ perpetrate.c -- main routine for C-INTERCAL compiler.
+
+DESCRIPTION
+ This is where all the dirty work begins and ends.
+
+LICENSE TERMS
+ Copyright (C) 1996 Eric S. Raymond
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+****************************************************************************/
+/*LINTLIBRARY */
+#include <stdio.h>
+#include <stdlib.h>
+#include <unistd.h>
+#include <string.h>
+#include <signal.h>
+#include <time.h>
+#include "ick.h"
+#include "feh.h"
+#include "y.tab.h"
+#include "sizes.h"
+#include "lose.h"
+
+#ifndef ICKINCLUDEDIR
+#define ICKINCLUDEDIR "/usr/local/include"
+#endif
+#ifndef ICKLIBDIR
+#define ICKLIBDIR "/usr/local/share"
+#endif
+#ifndef CC
+#define CC "gcc"
+#endif
+
+#ifdef USE_YYRESTART
+/* function supplied by lex */
+extern void yyrestart(FILE*);
+#endif /* USE_YYRESTART */
+
+/* function created by yacc */
+extern int yyparse(void);
+
+int yydebug;
+
+/* compilation options */
+bool compile_only; /* just compile into C, don't run the linker */
+bool traditional; /* insist on strict INTERCAL-72 conformance */
+bool nocompilerbug; /* disable error E774 */
+
+static bool dooptimize; /* do optimizations? (controlled by -O) */
+static bool clockface; /* set up output to do IIII for IV */
+
+#define SKELETON "ick-wrap.c"
+#define SYSLIB "pit/lib/syslib"
+
+/* numeric base defaults, exported to other files */
+
+#define DEFAULT_BASE 2
+#define DEFAULT_SMALL_DIGITS 16
+#define DEFAULT_LARGE_DIGITS 32
+#define DEFAULT_MAX_SMALL 0xffffL
+#define DEFAULT_MAX_LARGE 0xffffffffL
+
+int Base;
+int Small_digits;
+int Large_digits;
+unsigned int Max_small;
+unsigned int Max_large;
+
+int lineno; /* after yyparse, this is the total number of statements */
+
+/* currently supported numeric bases, not exported */
+static int maxbase = 7;
+static int smallsizes[8] = {0, 0, 16, 10, 8, 6, 6, 5};
+static unsigned int maxsmalls[8] =
+ {0, 0, 65535, 59048, 65535, 15624, 46655, 16806};
+
+static char *compiler;
+
+atom *oblist = NULL, *obdex;
+int obcount = 0;
+int nonespots, ntwospots, ntails, nhybrids;
+
+tuple *tuples = NULL;
+int tuplecount = 0;
+
+static void abend(int signim)
+{
+ lose(E778, yylineno, (char *)NULL);
+ (void) signim;
+}
+
+static void print_usage(char *prog, char *options)
+{
+ fprintf(stderr,"Usage: %s [-%s] <file> [<file> ... ]\n",prog,options);
+ fprintf(stderr,"\t-b\t:reduce the probability of E774 to zero\n");
+ fprintf(stderr,"\t-c\t:compile INTERCAL to C, but don't compile C\n");
+ fprintf(stderr,"\t-d\t:print debugging information (implies -c)\n");
+ fprintf(stderr,"\t-t\t:traditional mode, accept only INTERCAL-72\n");
+ fprintf(stderr,"\t-C\t:clockface output (e.g. use IIII instead of IV)\n");
+ fprintf(stderr,"\t-O\t:attempt to optimize generated code\n");
+ fprintf(stderr,"\t<file>\tINTERCAL source file(s) (use extension .i)\n");
+ fprintf(stderr,"\t\teach file produces a separate output program.\n");
+}
+
+int main(int argc, char *argv[])
+{
+ extern int optind; /* set by getopt */
+ char buf[BUFSIZ], buf2[BUFSIZ], *chp, *strrchr();
+ tuple *tp;
+ atom *op;
+ int c, i;
+ char *includedir, *libdir, *getenv();
+ FILE *ifp, *ofp;
+ int maxabstain, nextcount, bugline;
+ bool needsyslib, firstfile;
+
+ if (!(includedir = getenv("ICKINCLUDEDIR")))
+ includedir = ICKINCLUDEDIR;
+ if (!(libdir = getenv("ICKLIBDIR")))
+ libdir = ICKLIBDIR;
+ if (!(compiler = getenv("CC")))
+ compiler = CC;
+
+ while ((c = getopt(argc, argv, "bcdtOC@")) != EOF)
+ {
+ switch (c)
+ {
+ case 'b':
+ nocompilerbug = TRUE;
+ break;
+
+ case 'c':
+ compile_only = TRUE;
+ break;
+
+ case 'd':
+ yydebug = compile_only = TRUE;
+ break;
+
+ case 'C':
+ clockface = TRUE;
+ break;
+
+ case 't':
+ traditional = TRUE;
+ break;
+
+ case 'O':
+ dooptimize = TRUE;
+ break;
+
+ case '?':
+ default:
+ case '@':
+ print_usage(argv[0],"bcdtCO");
+ exit(1);
+ break;
+ }
+ }
+
+ (void) signal(SIGSEGV, abend);
+#ifdef SIGBUS
+ (void) signal(SIGBUS, abend);
+#endif /* SIGBUS */
+
+ if (!nocompilerbug) {
+#ifdef USG
+ srand48(time(NULL) + getpid());
+#else
+ srand(time(NULL));
+#endif /* UNIX */
+ }
+
+ (void) sprintf(buf2,"%s/%s",libdir,SKELETON);
+
+ /* now substitute in tokens in the skeleton */
+ if ((ifp = fopen(buf2, "r")) == (FILE *)NULL)
+ lose(E999, 1, (char *)NULL);
+ buf[strlen(buf) - 2] = '\0';
+
+ for (firstfile = TRUE; optind < argc; optind++, firstfile = FALSE)
+ {
+ if (freopen(argv[optind], "r", stdin) == (FILE *)NULL)
+ lose(E777, 1, (char *)NULL);
+ else
+ {
+ /* strip off the file extension */
+ if(!(chp = strrchr(argv[optind],'.')))
+ {
+ lose(E998, 1, (char *)NULL);
+ }
+ *chp++ = '\0';
+
+ /* wwp: reset the base variables to defaults, because if the */
+ /* sourcefile has extension .i they will not be reset in the */
+ /* following chunk of code. but i don't want to modify the */
+ /* following chunk of code because i think it is very clever; */
+ /* grabs the base on the first pass, then validates the rest */
+ /* of the extension on the second. */
+ Base = DEFAULT_BASE;
+ Small_digits = DEFAULT_SMALL_DIGITS;
+ Large_digits = DEFAULT_LARGE_DIGITS;
+ Max_small = DEFAULT_MAX_SMALL;
+ Max_large = DEFAULT_MAX_LARGE;
+
+ /* determine the file type from the extension */
+ while (strcmp(chp,"i"))
+ {
+ Base = strtol(chp,&chp,10);
+ if (Base < 2 || Base > maxbase)
+ lose(E998, 1, (char *)NULL);
+ else if (traditional && Base != 2)
+ lose(E111, 1, (char *)NULL);
+ Small_digits = smallsizes[Base];
+ Large_digits = 2 * Small_digits;
+ Max_small = maxsmalls[Base];
+ if (Max_small == 0xffff)
+ Max_large = 0xffffffff;
+ else
+ Max_large = (Max_small + 1) * (Max_small + 1) - 1;
+ }
+
+ /* zero out tuple and oblist storage */
+ treset();
+ politesse = 0;
+
+ /* reset the lex/yacc environment */
+ if (!firstfile)
+ {
+#ifdef NEED_YYRESTART
+ yyrestart(stdin);
+#endif /* NEED_YYRESTART */
+#ifdef YYLINENO_BY_HAND
+ yylineno = 1;
+#endif /* YYLINENO_BY_HAND */
+ }
+
+ /* compile tuples from current input source */
+ yyparse();
+
+ /*
+ * Miss Manners lives.
+ */
+ if (lineno > 2)
+ {
+ if (politesse == 0 || (lineno - 1) / politesse >= 5)
+ lose(E079, yylineno, (char *)NULL);
+ else if (lineno / politesse < 3)
+ lose(E099, yylineno, (char *)NULL);
+ }
+
+ /*
+ * check if we need to magically include the system library
+ */
+ needsyslib = FALSE;
+ for (tp = tuples; tp->type; tp++) {
+ /*
+ * If some label in the (1000)-(2000) range is defined,
+ * then clearly the syslib is already there, so we
+ * can stop searching and won't need the syslib.
+ */
+ if (tp->label >= 1000 && tp->label <= 1999) {
+ needsyslib = FALSE;
+ break;
+ }
+ /*
+ * If some label in the (1000)-(2000) range is being
+ * called, we might need the system library.
+ */
+ if (tp->type == NEXT && tp->u.target >= 1000 &&
+ tp->u.target <= 1999)
+ needsyslib = TRUE;
+ }
+ if ( needsyslib ) {
+ if (Base == 2)
+ (void) sprintf(buf2, "%s/%s.i", libdir, SYSLIB);
+ else
+ (void) sprintf(buf2, "%s/%s.%di", libdir, SYSLIB, Base);
+ if ( freopen(buf2, "r", stdin) == (FILE*) NULL ) {
+ lose(E127, 1, (char*) NULL);
+ }
+#ifdef USE_YYRESTART
+ yyrestart(stdin);
+#endif /* USE_YYRESTART */
+ yyparse();
+ }
+
+ /*
+ * Now propagate type information up the expression tree.
+ * We need to do this because the unary-logical operations
+ * are sensitive to the type widths of their operands, so
+ * we have to generate different code depending on the
+ * deducible type of the operand.
+ */
+ for (tp = tuples; tp->type; tp++)
+ if (tp->type == GETS || tp->type == RESIZE
+ || tp->type == FORGET || tp->type == RESUME)
+ typecast(tp->u.node);
+
+ codecheck(); /* check for compile-time errors */
+
+ /* perform optimizations */
+ if (dooptimize)
+ for (tp = tuples; tp->type; tp++)
+ if (tp->type == GETS || tp->type == RESIZE
+ || tp->type == FORGET || tp->type == RESUME)
+ optimize(tp->u.node);
+
+ /* decide if and where to place the compiler bug */
+#ifdef USG
+ if (!nocompilerbug && lrand48() % 10 == 0)
+ bugline = (int)(lrand48() % lineno);
+#else
+ if (!nocompilerbug && rand() % 10 == 0)
+ bugline = rand() % lineno;
+#endif
+ else
+ bugline = -1;
+
+ /* set up the generated C output file name */
+ (void) strcpy(buf, argv[optind]);
+ (void) strcat(buf, ".c");
+ if ((ofp = fopen(buf, "w")) == (FILE *)NULL)
+ lose(E888, 1, (char *)NULL);
+
+ fseek(ifp,0L,0); /* rewind skeleton file */
+
+ while ((c = fgetc(ifp)) != EOF)
+ if (c != '$')
+ (void) fputc(c, ofp);
+ else switch(fgetc(ifp))
+ {
+ case 'A': /* source name stem */
+ (void) fputs(argv[optind], ofp);
+ break;
+
+ case 'B': /* # of statements */
+ (void) fprintf(ofp, "%d", lineno);
+ break;
+
+ case 'C': /* initial abstentions */
+ maxabstain = 0;
+ for (tp = tuples; tp->type; tp++)
+ if (tp->exechance <= 0 && tp - tuples + 1 > maxabstain)
+ maxabstain = tp - tuples + 1;
+ if (maxabstain)
+ {
+ (void) fprintf(ofp, " = {");
+ for (tp = tuples; tp < tuples + maxabstain; tp++)
+ if (tp->exechance > 0)
+ (void) fprintf(ofp, "0, ");
+ else {
+ (void) fprintf(ofp, "1, ");
+ tp->exechance = -tp->exechance;
+ }
+ (void) fprintf(ofp, "}");
+ }
+ break;
+
+ case 'D': /* linetypes array for abstention handling */
+ maxabstain = 0;
+ for (tp = tuples; tp->type; tp++)
+ if (tp->type == ENABLE || tp->type == DISABLE)
+ maxabstain++;
+ if (maxabstain)
+ {
+ (void) fprintf(ofp, "#define UNKNOWN\t\t0\n");
+ i = 0;
+ for (; i < (int)(sizeof(enablers)/sizeof(char *)); i++)
+ (void) fprintf(ofp,
+ "#define %s\t%d\n",
+ enablers[i], i+1);
+
+ (void) fprintf(ofp, "int linetype[] = {\n");
+ for (tp = tuples; tp->type; tp++)
+ if (tp->type >= GETS && tp->type <= COME_FROM)
+ (void) fprintf(ofp,
+ " %s,\n",
+ enablers[tp->type - GETS]);
+ else
+ (void) fprintf(ofp, " UNKNOWN,\n");
+ (void) fprintf(ofp, "};\n");
+ }
+ break;
+
+ case 'E': /* extern to intern map */
+ (void) fprintf(ofp,"int Base = %d;\n",Base);
+ (void) fprintf(ofp,"int Small_digits = %d;\n",
+ Small_digits);
+ (void) fprintf(ofp,"int Large_digits = %d;\n",
+ Large_digits);
+ (void) fprintf(ofp,"unsigned int Max_small = 0x%x;\n",
+ Max_small);
+ (void) fprintf(ofp,"unsigned int Max_large = 0x%x;\n",
+ Max_large);
+ if (nonespots)
+ {
+ (void) fprintf(ofp,
+ "static type16 onespots[%d];\n",
+ nonespots);
+ (void) fprintf(ofp,
+ "static bool oneforget[%d];\n",
+ nonespots);
+ }
+ if (ntwospots)
+ {
+ (void) fprintf(ofp,
+ "static type32 twospots[%d];\n",
+ ntwospots);
+ (void) fprintf(ofp,
+ "static bool twoforget[%d];\n",
+ ntwospots);
+ }
+ if (ntails)
+ {
+ (void) fprintf(ofp,
+ "static array tails[%d];\n",
+ ntails);
+ (void) fprintf(ofp,
+ "static bool tailforget[%d];\n",
+ ntails);
+ }
+ if (nhybrids)
+ {
+ (void) fprintf(ofp,
+ "static array hybrids[%d];\n",
+ nhybrids);
+ (void) fprintf(ofp,
+ "static bool hyforget[%d];\n",
+ nhybrids);
+ }
+ if (yydebug || compile_only)
+ for (op = oblist; op < obdex; op++)
+ (void) fprintf(ofp, " /* %s %d -> %d */\n",
+ nameof(op->type, vartypes),
+ op->extindex,
+ op->intindex);
+ break;
+
+ case 'F': /* set clockface option? */
+ if (clockface)
+ (void) fprintf(ofp, "clockface(TRUE);");
+ break;
+
+ case 'G': /* degenerated code */
+ for (tp = tuples, i = 0; tp->type; tp++, i++)
+ {
+ emit(tp, ofp);
+ if (i == bugline)
+ (void) fprintf(ofp, " lose(E774, lineno, "
+ "(char *)NULL);\n");
+ }
+ break;
+
+ case 'H': /* dispatching for resumes */
+ nextcount = 0;
+ for (tp = tuples; tp->type; tp++)
+ if (tp->type == NEXT)
+ nextcount++;
+ if (nextcount)
+ {
+ (void) fputs("/* generated switch for resumes */",ofp);
+ (void) fputs("top:\n switch(skipto)\n {\n", ofp);
+ for (tp = tuples; tp->type; tp++)
+ if (tp->type == NEXT)
+ (void) fprintf(ofp,
+ "\tcase %d: goto N%d; break;\n",
+ (int)(tp-tuples+1), (int)(tp-tuples+1));
+ (void) fprintf(ofp, " }");
+ }
+ break;
+
+ case 'J': /* # of source file lines */
+ (void) fprintf(ofp, "%d", yylineno);
+ break;
+ }
+
+ (void) fclose(ofp);
+
+ /* OK, now sic the C compiler on the results */
+ if (!compile_only)
+ {
+ (void) sprintf(buf2,
+ "%s %s -I%s -L%s -lick -o %s",
+ compiler, buf, includedir, libdir,
+ argv[optind]);
+ (void) system(buf2);
+ (void) unlink(buf);
+ }
+ }
+ }
+ (void) fclose(ifp);
+ return 0;
+}
+
+/* perpetrate.c ends here */
-This is the directory of programs written in INTERCAL. It is named
-pit because src was already taken---that's where source code for the
-compiler lives---and pit seemed an appropriate place to throw
-INTERCAL programs anyway. Most of these are no doubt full of bugs.
-Don't complain, you're lucky if anything written in INTERCAL works
-at all.
+This is the directory of programs written in INTERCAL. Most of these
+are no doubt full of bugs. Don't complain, you're lucky if anything
+written in INTERCAL works at all.
The subdirectory lib contains code fragments that are not complete
programs.
The subdirectory tests contains some programs written only to test the
compiler.
+by Donald Knuth
+ knuth.i Demonstrates Don Knuth's patch for handling multiline comments
+
by David Moews
test1.i Prints DO THIS TEST HAS BEEN SUCCESSFULLY COMPLETED
test2.i Reads in two numbers and multiplies their product
# Torture-tester for the INTERCAL compiler
#
-ICK = ../src/ick -b
+ICK = ../ick -b
SOURCES = \
./sample.i \
--- /dev/null
+ PLEASE ABSTAIN FROM (1)
+(1) DON KNUTH'S IMPLEMENTATION OF TPK IN INTERCAL
+ (C) MARCH 2003
+ REFERENCE --- THE EARLY HISTORY OF PROGRAMMING
+ LANGUAGES, BY D E KNUTH AND L TRABB PARDO
+
+ NOTA BENE: THE INPUT AND OUTPUT DATA ARE SCALED
+ DECIMAL NUMBERS WITH SIX DIGITS TO THE RIGHT OF
+ THE DECIMAL POINT; THUS AN INPUT OF
+ THREE ONE FOUR ONE FIVE NINE THREE
+ DENOTES 3.141593, AND THAT VALUE WOULD BE OUTPUT AS
+ ______
+ MMMCXLMDXCIII
+
+ VARIABLE NAMES AND SUBROUTINE NAMES USE THE CLASSIC
+ 5-BIT TELEPRINTER CODE IN LETTER-SHIFT MODE, NAMELY
+ / E @ A : S I U 1/4 D R J N F C K T Z L W H Y P Q O B G " M X V $
+ (WHICH ALAN TURING ADVISED EVERY PROGRAMMER TO LEARN)
+
+ DO GIVE UP
--- /dev/null
+ PLEASE .1 <- #1$#0
+ DO .2 <- #1¢#0
+ DO .3 <- #1£#0
+ DO .4 <- #1¤#0
+ PLEASE READ OUT .1
+ DO READ OUT .2
+ DO READ OUT .3
+ DO READ OUT .4
+ PLEASE GIVE UP
--- /dev/null
+/* sizes.h -- constants defining the numeric base for INTERCAL variations */
+
+extern int Base;
+extern int Small_digits;
+extern int Large_digits;
+extern unsigned int Max_small;
+extern unsigned int Max_large;
+
+/* sizes.h ends here */
--- /dev/null
+#!/bin/sh
+
+version=$1
+
+cat <<EOF
+Name: intercal
+Version: ${version}
+Release: 1
+URL: http://www.catb.org/~esr/intercal/
+Source: intercal-${version}.tar.gz
+License: GPL
+Group: Development/Languages
+Summary: the language that kills the weak and drives mad the strong
+
+%description
+An implementation of the language INTERCAL, legendary for
+its perversity and horribleness (this version adds COME FROM
+for extra flavor). Comes with language manual and examples
+including possibly the entire extant body of INTERCAL code.
+Now supports i18n and l14n (to Ancient Roman locale only)
+Now with fix patch by Donald Knuth.
+
+%prep
+%setup -q
+
+%build
+configure --prefix=/usr
+make
+
+%install
+rm -fr /usr/share/intercal-${version}/*
+make install
+
+%files
+/usr/bin/ick
+/usr/lib/libick.a
+/usr/include/intercal-${version}/lose.h
+/usr/include/intercal-${version}/abcess.h
+/usr/include/intercal-${version}/fiddle.h
+/usr/share/intercal-${version}/ick-wrap.c
+/usr/share/intercal-${version}/
+%doc README BUGS NEWS
+EOF
+#find pit -type f -print | sed -e "/^/s//\/usr\/share\/intercal-${version}\//" -e '/RCS/d'
+
+
+++ /dev/null
-# Makefile for the INTERCAL compiler
-
-# Set BINDIR, INCDIR, LIBDIR to the locations where you want "make install"
-# to install the executable, include files, and library for the compiler.
-# The compiler will look there for the stuff it needs when you compile
-# INTERCAL programs. INCDIR and LIBDIR can be this directory if you don't
-# want to "make install", e.g., if you don't trust makefiles moving stuff
-# all over creation behind your back.
-# (/dev/null may be another good choice :-))
-
-BINDIR = /usr/bin
-INCDIR = /usr/include/intercal
-SHAREDIR = /usr/share/intercal
-LIBDIR = /usr/share/intercal/lib
-#INCDIR = $(PWD)
-#LIBDIR = $(PWD)
-
-YDEBUG = -vlt
-DEBUG = -g -DDEBUG
-# DEBUG = -O
-
-# This version (from 0.18) is POSIX-compliant. You should only set the POSIX
-# variable to null if you *need* to use the old <varargs.h> support;
-# otherwise, the ANSI-compliant <stdarg.h> library will be used.
-
-# POSIX =
-POSIX = -D_POSIX_SOURCE
-
-CFLAGS = -I. $(DEBUG) -DICKINCLUDEDIR=\"$(INCDIR)\" \
- -DICKLIBDIR=\"$(LIBDIR)\" -DYYDEBUG $(POSIX)
-LDFLAGS =
-
-CC = gcc -Wall -W
-
-# You can use lex or flex
-#LEX = lex
-LEX = flex
-
-# You should use bison, because some yaccs won't work correctly
-YACC = bison -y
-
-CSOURCES = ick.y lexer.l feh.c lose.c fiddle.c perpetrate.c
-ISOURCES = cesspool.c arrgghh.c ick-wrap.c
-HEADERS = ick.h lose.h sizes.h abcess.h fiddle.h feh.h
-SOURCES = $(CSOURCES) $(ISOURCES) $(HEADERS)
-
-all: ick libick.a
-
-ick: ick.o lexer.o feh.o lose.o fiddle.o perpetrate.o
- $(CC) perpetrate.o ick.o lexer.o feh.o lose.o fiddle.o $(LDFLAGS) -o ick
-
-y.tab.h ick.c: ick.y ick.h sizes.h feh.h lose.h
- $(YACC) -d $(YDEBUG) ick.y
- mv y.tab.c ick.c
-
-lexer.c: lexer.l ick.h lose.h
- $(LEX) $(LFLAGS) lexer.l
- mv lex.yy.c lexer.c
-
-# Uncomment the following if using a stock lex
-# LEXLIBS = -ll
-lextest: y.tab.h lexer.c ick.h lose.o
- $(CC) -DMAIN lexer.c lose.o $(LEXLIBS) -o lextest
-
-ick.o: ick.c ick.h feh.h lose.h sizes.h
-lexer.o: lexer.c y.tab.h ick.h lose.h
-feh.o: feh.c feh.h y.tab.h ick.h fiddle.h lose.h sizes.h
-perpetrate.o: perpetrate.c y.tab.h ick.h lose.h sizes.h
-cesspool.o: cesspool.c numerals.c abcess.h lose.h sizes.h
-lose.o: lose.h
-fiddle.o: fiddle.h sizes.h
-
-libick.a: cesspool.o lose.o fiddle.o arrgghh.o
- ar cr libick.a cesspool.o lose.o fiddle.o arrgghh.o
- -ranlib libick.a
-
-install: all
- cp ick $(BINDIR)
- -mkdir $(INCDIR)
- cp lose.h abcess.h fiddle.h ick-wrap.c $(INCDIR)
- -mkdir $(SHAREDIR)
- (cd ../pit; cp *.i *.3i t_tet *.fft glider gun blinkers $(SHAREDIR))
- -mkdir $(LIBDIR)
- cp libick.a $(LIBDIR)
- (cd ../pit/lib; cp *.*i $(LIBDIR))
-
-clean:
- rm -f yacc.* y.tab.* y.output *~ *.[oa] lexer.c ick.c lextest ick
-
-TAGS: $(SOURCES)
- etags $(SOURCES)
+++ /dev/null
-/* abcess.h -- functions used by compiled INTERCAL programs */
-
-typedef int bool;
-#define TRUE 1
-#define FALSE 0
-
-#define ONESPOT 0
-#define TWOSPOT 1
-#define TAIL 2
-#define HYBRID 3
-
-/* the following two types must both promote to unsigned int in expressions */
-
-typedef unsigned short type16;
-typedef unsigned int type32;
-
-typedef struct array_t
-{
- unsigned int rank;
- unsigned int *dims;
- union
- {
- type16 *tail;
- type32 *hybrid;
- } data;
-} array;
-
-/* defined in cesspool.c */
-extern void pushnext(int n);
-extern unsigned int popnext(int n);
-extern unsigned int resume(unsigned int n);
-extern unsigned int pin(void);
-extern void clockface(bool mode);
-extern void pout(unsigned int val);
-extern void binin(unsigned int type, array *a, bool forget);
-extern void binout(unsigned int type, array *a);
-extern unsigned int assign(char *dest, unsigned int type, bool forget,
- unsigned int value);
-
-#ifdef _POSIX_SOURCE
-extern char *aref(unsigned int type, ...);
-extern void resize(unsigned int type, ...);
-#else
-extern char *aref();
-extern void resize();
-#endif
-
-extern void stashinit(void);
-extern void stash(unsigned int type, unsigned int index, void *from);
-extern void retrieve(void *to, int type, unsigned int index, bool forget);
-extern unsigned int roll(unsigned int n);
-
-/* defined in arrgghh.c */
-extern void parseargs(int argc, char **argv);
-
-/* abcess.h ends here */
+++ /dev/null
-/*
- * SYNOPSIS: parseargs(argc,argv)
- * FILE : parseargs.c
- * AUTHOR : Steve Swales
- * DATE: October 7, 1990
- * PURPOSE: Parse arguments for INTERCAL programs.
- *
-LICENSE TERMS
- Copyright (C) 1996 Eric S. Raymond
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- */
-#include <stdio.h>
-#include <stdlib.h>
-#include <unistd.h>
-#include "abcess.h"
-#include "lose.h"
-
-int traditional = 0;
-int wimp_mode = 0;
-
-void
-parseargs(int argc, char **argv)
-{
- register int i, j;
- static int helpflag = -1;
- static char *flags[] = {
- "help",
- "wimpmode",
- "traditional"
- };
- static int *bools[] = {
- &helpflag,
- &wimp_mode,
- &traditional
- };
- static int nflags = (int)(sizeof(flags)/sizeof(flags[0]));
-
- for(i = 1;i < argc;i++) {
- if(argv[i][0] != '+' && argv[i][0] != '-') {
- break;
- }
- for(j = 0; j < nflags;j++) {
- if(0 == strcmp(argv[i]+1,flags[j])) {
- *(bools[j]) = (argv[i][0] == '+');
- break;
- }
- }
- if(j == nflags) {
- fprintf(stderr,"%s: can't grok %s\n",argv[0],argv[i]);
- helpflag = 1;
- }
- }
- if(helpflag != -1) {
- if(!helpflag) {
- fprintf(stderr,
- "Once you start messing with INTERCAL... \n");
- fprintf(stderr,"\t\tthere is no help for you!\n\n");
- sleep(3);
- }
- fprintf(stderr,"Current flags (and current state) are:\n");
- for(i = 0;i < nflags;i++) {
- fprintf(stderr,"\t[+/-]%-20.20s\t(%s)\n",flags[i],
- (*(bools[i]) == 1)?"ON":((*(bools[i]) == 0)?"OFF":"???"));
- }
- fprintf(stderr,"All flags must be preceded by either + or -, which\n");
- fprintf(stderr," usually will mean turn on or turn off something,\n");
- fprintf(stderr," but not always, and not all of them currently\n");
- fprintf(stderr," do anything, but you can switch them on or off\n");
- fprintf(stderr," if you like anyway. Isn't this helpful?\n\n");
- fflush(stderr);
- sleep(3);
- lose(E778, 0, (char *)NULL);
- }
- if(wimp_mode) {
- fprintf(stderr,"How sad... you have selected to run an INTERCAL\n");
- fprintf(stderr,"program in WIMP MODE.\n\n");
- fprintf(stderr,"This means that:\n");
- fprintf(stderr," A) Rather than the nifty input like:\n");
- fprintf(stderr,"\tONE NINER SEVEN TWO OH SIX THREE,\n");
- fprintf(stderr," and even niftier output like:\n");
- fprintf(stderr,"\t______\n");
- fprintf(stderr,"\tMCMLXXMMLXIII,\n");
- fprintf(stderr," you will have to settle for plain old number\n");
- fprintf(stderr," representations like 1972063; and,\n");
- fprintf(stderr," B) You are a WIMP!\n\n");
- fflush(stderr);
- }
-}
+++ /dev/null
-/*****************************************************************************
-
-NAME
- cesspool.c -- storage management and runtime support for INTERCAL
-
-LICENSE TERMS
- Copyright (C) 1996 Eric S. Raymond
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-***************************************************************************/
-/* LINTLIBRARY */
-#include <stdio.h>
-#include <stdlib.h>
-
-#ifdef _POSIX_SOURCE
-#include <stdarg.h>
-#else
-#include <varargs.h>
-#endif
-
-#include "sizes.h"
-#include "abcess.h"
-#include "lose.h"
-
-#include "numerals.c"
-
-/**********************************************************************
- *
- * The following functions manipulate the nexting stack
- *
- *********************************************************************/
-
-#define MAXNEXT 80
-
-int next[MAXNEXT];
-int nextindex = 0;
-
-void pushnext(int n)
-{
- if (nextindex < MAXNEXT)
- next[nextindex++] = n;
- else
- lose(E123, lineno, (char *)NULL);
-}
-
-unsigned int popnext(int n)
-{
- nextindex -= n;
- if (nextindex < 0) {
- nextindex = 0;
- return (unsigned int)-1;
- }
- return(next[nextindex]);
-}
-
-unsigned int resume(unsigned int n)
-{
- if (n == 0)
- {
- lose(E621, lineno, (char *)NULL);
- return 0;
- }
- else if ((n = popnext(n)) == (unsigned int)-1)
- {
- lose(E632, lineno, (char *)NULL);
- return 0;
- }
- return(n);
-}
-
-/**********************************************************************
- *
- * The following functions implement the INTERCAL I/O model
- *
- *********************************************************************/
-
-unsigned int pin(void)
-{
- char buf[BUFSIZ], *cp, *strtok();
- unsigned int result = 0;
- int n;
- extern int wimp_mode;
-
- if (fgets(buf, BUFSIZ, stdin) == (char *)NULL)
- lose(E562, lineno, (char *)NULL);
- n = strlen(buf) - 1;
- if (buf[n-1] == '\r')
- --n;
- buf[n] = '\0';
-
- if(wimp_mode) {
- result = (unsigned int)strtoul(buf, (char **)NULL, 10);
- n = 1;
- }
- else
- {
- for(n=0,cp = strtok(buf, " ");cp;cp = strtok((char *)NULL, " "),n++)
- {
- int digit = -1;
- numeral *np;
-
- for (np = numerals; np < numerals + sizeof(numerals)/sizeof(numeral); np++)
- if (strcmp(np->name, cp) == 0)
- {
- digit = np->value;
- break;
- }
-
- if (digit == -1)
- lose(E579, lineno, cp);
-
- if (result < 429496729 || (result == 429496729 && digit < 6))
- result = result * 10 + digit;
- else
- lose(E533, lineno, (char *)NULL);
- }
- }
- if (!n)
- lose(E562, lineno, (char *)NULL);
- if (result > (unsigned int)Max_large)
- lose(E533, lineno, (char *)NULL);
- return(result);
-}
-
-/**********************************************************************
- *
- * Butchered Roman numerals implemented by
- * Michael Ernst, mernst@theory.lcs.mit.edu. May 7, 1990
- *
- * The INTERCAL manual hints that 3999 should translate to MMMIM
- * (compare MMMCMXCIX) without specifying what the translation is.
- * That may be a typo; in any case, this implementation isn't that
- * butchered.
- *
- *********************************************************************/
-
-#define MAXDIGITS 10 /* max base 10 digits */
-#define MAXROMANS (MAXDIGITS*4+1) /* max chars in translation */
-
-/*
- * The first column tells how many of the succeeding columns are used.
- * The other columns refer to the columns of br_equiv and br_overbar.
- */
-static int br_trans[10][5] =
-{
- {0, 0, 0, 0, 0},
- {1, 0, 0, 0, 0},
- {2, 0, 0, 0, 0},
- {3, 0, 0, 0, 0},
- {2, 1, 2, 0, 0}, /* or use {4, 0, 0, 0, 0} */
- {1, 2, 0, 0, 0},
- {2, 2, 1, 0, 0},
- {3, 2, 1, 1, 0},
- {4, 2, 1, 1, 1},
- {2, 1, 3, 0, 0}
-};
-
-/*
- * butcher places in the string result the "butchered" Roman numeral for val.
- * This string should be printed at the beginning of a line; it spans two
- * lines and already contains newlines.
- *
- * 11/24/91 LHH: Removed unnecessary final newline.
- */
-
-static void butcher(unsigned long val, char *result)
-{
- int i, j;
- int digitsig, digitval;
- char res[MAXROMANS], ovb[MAXROMANS];
-
- /* We need FOUR columns because of the odd way that M and I interact. */
- static char br_equiv[MAXDIGITS][4] =
- {
- {'I', 'I', 'V', 'X'}, {'X', 'X', 'L', 'C'},
- {'C', 'C', 'D', 'M'}, {'M', 'I', 'V', 'X'},
- {'X', 'X', 'L', 'C'}, {'C', 'C', 'D', 'M'},
- {'M', 'i', 'v', 'x'}, {'x', 'x', 'l', 'c'},
- {'c', 'c', 'd', 'm'}, {'m', 'i', 'v', 'x'},
- };
-
- static char br_overbar[MAXDIGITS][4] =
- {
- {' ', ' ', ' ', ' '},
- {' ', ' ', ' ', ' '},
- {' ', ' ', ' ', ' '},
- {' ', '_', '_', '_'},
- {'_', '_', '_', '_'},
- {'_', '_', '_', '_'},
- {'_', ' ', ' ', ' '},
- {' ', ' ', ' ', ' '},
- {' ', ' ', ' ', ' '},
- {' ', '_', '_', '_'},
- };
-
- if (val == 0)
-/* Final newline will be added by puts.
- (void) strcpy(result, "_\n \n");
-*/
- (void) strcpy(result, "_\n");
- else
- {
- res[MAXROMANS-1] = 0;
- ovb[MAXROMANS-1] = 0;
- i = MAXROMANS-1;
-
- /* the significance of the current digit is 10 ** digitsig */
- for (digitsig = 0; (digitsig < MAXDIGITS) && (val > 0); digitsig++)
- {
- digitval = val % 10;
- for (j = br_trans[digitval][0]; j > 0; j--)
- {
- /* printf("In j loop: %d %d\n", j, i); */
- res[--i] = br_equiv[digitsig][br_trans[digitval][j]];
- ovb[i] = br_overbar[digitsig][br_trans[digitval][j]];
- }
- val = val / 10;
- }
-
- j = i;
- while ((*result++ = ovb[j++]))
- continue;
- *--result = '\n';
-
- j = i;
- while ((*++result = res[j++]))
- continue;
-/* Final newline will be added by puts.
- *result++ = '\n';
-*/
- *result = '\0';
- }
-}
-
-void clockface(bool mode)
-/* enable or disable clockface mode (output IIII instead of IV) */
-{
- if (mode)
- {
- /* clockface mode */
- br_trans[4][0] = 4;
- br_trans[4][1] = 0;
- br_trans[4][2] = 0;
- }
- else
- {
- /* normal mode */
- br_trans[4][0] = 2;
- br_trans[4][1] = 1;
- br_trans[4][2] = 2;
- }
-}
-
-void pout(unsigned int val)
-/* output in `butchered' Roman numerals; see manual, part 4.4.13 */
-{
- char result[2*MAXROMANS+1];
- extern int wimp_mode;
-
- if(wimp_mode) {
- printf("%u\n",val);
- }
- else {
- butcher(val, result);
- (void) puts(result);
- }
- fflush(stdout);
-}
-
-/**********************************************************************
- *
- * The following two routines implement bitwise I/O. They assume
- * 8 bit characters, but there's no reason more general versions
- * could not be written.
- *
- *********************************************************************/
-
-void binin(unsigned int type, array *a, bool forget)
-{
- static unsigned int lastin = 0;
- int c, v;
- unsigned int i;
-
- if (a->rank != 1)
- lose(E241, lineno, (char *)NULL);
-
- for (i = 0 ; i < a->dims[0] ; i++) {
- v = ((c=getchar()) == EOF) ? 256 : (c - lastin) % 256;
- lastin = c;
- if (!forget) {
- if (type == TAIL)
- a->data.tail[i] = v;
- else
- a->data.hybrid[i] = v;
- }
- }
-}
-
-void binout(unsigned int type, array *a)
-{
- static unsigned int lastout = 0;
- unsigned int i, c;
-
- if (a->rank != 1)
- lose(E241, lineno, (char *)NULL);
-
- for (i = 0 ; i < a->dims[0] ; i++) {
- if (type == TAIL)
- c = lastout - a->data.tail[i];
- else
- c = lastout - a->data.hybrid[i];
- lastout = c;
- c = (c & 0x0f) << 4 | (c & 0xf0) >> 4;
- c = (c & 0x33) << 2 | (c & 0xcc) >> 2;
- c = (c & 0x55) << 1 | (c & 0xaa) >> 1;
- putchar(c);
- if (c == '\n')
- fflush(stdout);
- }
-}
-
-/**********************************************************************
- *
- * The following assignment function performs IGNORE and type checks
- *
- *********************************************************************/
-
-unsigned int assign(char *dest, unsigned int type, bool forget,
- unsigned int value)
-{
- unsigned int retval;
- if (type == ONESPOT || type == TAIL) {
- if (value > (unsigned int)Max_small)
- lose(E275, lineno, (char *)NULL);
- if (forget)
- retval = value;
- else {
- retval = *(type16*)dest;
- *(type16*)dest = value;
- }
- }
- else if (type == TWOSPOT || type == HYBRID) {
- if (forget)
- retval = value;
- else {
- retval = *(type32*)dest;
- *(type32*)dest = value;
- }
- }
- return retval;
-}
-
-/**********************************************************************
- *
- * The following functions implement the INTERCAL array model
- * If _POSIX_SOURCE is defined, stdarg is used, otherwise varargs.
- *
- *********************************************************************/
-
-
-#ifdef _POSIX_SOURCE
-char *aref(unsigned int type, ...)
-#else
-char *aref(va_alist) va_dcl
-#endif
-/* return a pointer to the array location specified by args */
-{
-#ifndef _POSIX_SOURCE
- unsigned int type;
-#endif
- array *a;
- unsigned int v;
- va_list ap;
- int address = 0;
- unsigned int i;
-
-#ifdef _POSIX_SOURCE
- va_start(ap, type);
-#else
- va_start(ap);
- type = va_arg(ap, unsigned int);
-#endif
- a = va_arg(ap, array*);
-
- if (va_arg(ap, unsigned int) != a->rank)
- lose(E241, lineno, (char *)NULL);
-
- for (i = 0 ; i < a->rank ; i++) {
- v = va_arg(ap, unsigned int);
- if (v == 0 || v > a->dims[i])
- lose(E241, lineno, (char *)NULL);
- address = address * a->dims[i] + v - 1;
- }
-
- va_end(ap);
-
- if (type == TAIL)
- return (char*)&a->data.tail[address];
- else
- return (char*)&a->data.hybrid[address];
-}
-
-#ifdef _POSIX_SOURCE
-void resize(unsigned int type, ...)
-#else
-void resize(va_alist) va_dcl
-#endif
-/* resize an array to the given shape */
-{
-#ifndef _POSIX_SOURCE
- unsigned int type;
-#endif
- array *a;
- bool forget;
- unsigned int i, r, v;
- va_list ap;
- int prod = 1;
-
-#ifdef _POSIX_SOURCE
- va_start(ap, type);
-#else
- va_start(ap);
- type = va_arg(ap, unsigned int);
-#endif
- a = va_arg(ap, array*);
- forget = va_arg(ap, bool);
-
- r = va_arg(ap, unsigned int);
- if (!forget) {
- a->rank = r;
- if (a->dims)
- free((char*)a->dims);
- a->dims = (unsigned int*) malloc(a->rank * sizeof(unsigned int));
- if (a->dims == NULL)
- lose(E241, lineno, (char *)NULL);
- }
-
- for (i = 0 ; i < r ; i++) {
- v = va_arg(ap, unsigned int);
- if (v == 0)
- lose(E240, lineno, (char *)NULL);
- if (!forget) {
- a->dims[i] = v;
- prod *= v;
- }
- }
-
- if (!forget) {
- if (type == TAIL) {
- if (a->data.tail)
- free((char *)a->data.tail);
- a->data.tail = (type16*)malloc(prod * sizeof(type16));
- if (a->data.tail == NULL)
- lose(E241, lineno, (char *)NULL);
- }
- else {
- if (a->data.hybrid)
- free((char *)a->data.hybrid);
- a->data.hybrid = (type32*)malloc(prod * sizeof(type32));
- if (a->data.hybrid == NULL)
- lose(E241, lineno, (char *)NULL);
- }
- }
-
- va_end(ap);
-}
-
-/**********************************************************************
- *
- * The following functions implement save/retrieve
- *
- *********************************************************************/
-
-typedef struct stashbox_t /* this is a save-stack element */
-{
- unsigned int type; /* variable type */
- unsigned int index; /* variable's index within the type */
- union /* the data itself */
- {
- type16 onespot;
- type32 twospot;
- array *a;
- } save;
- struct stashbox_t *next; /* pointer to next-older stashbox */
-} stashbox;
-
-static stashbox *first;
-
-void stashinit(void)
-{
- first = NULL;
-}
-
-static stashbox *fetch(unsigned int type, unsigned int index)
-/* find a stashed variable in the save stack and extract it */
-{
- stashbox **pp = &first, *sp = first;
-
- while (sp && (sp->type != type || sp->index != index)) {
- pp = &sp->next;
- sp = sp->next;
- }
- if (sp)
- *pp = sp->next;
-
- return (sp);
-}
-
-void stash(unsigned int type, unsigned int index, void *from)
-/* stash away the variable's value */
-{
- /* create a new stashbox and push it onto the stack */
- stashbox *sp = (stashbox*)malloc(sizeof(stashbox));
- if (sp == NULL) lose(E222, lineno, (char *)NULL);
- sp->next = first;
- first = sp;
-
- /* store the variable in it */
- sp->type = type;
- sp->index = index;
- if (type == ONESPOT)
- memcpy((char *)&sp->save.onespot, from, sizeof(type16));
- else if (type == TWOSPOT)
- memcpy((char *)&sp->save.twospot, from, sizeof(type32));
- else if (type == TAIL || type == HYBRID) {
- array *a = (array*)from;
- int prod;
- unsigned int i;
- sp->save.a = (array*)malloc(sizeof(array));
- if (sp->save.a == NULL) lose(E222, lineno, (char *)NULL);
- sp->save.a->rank = a->rank;
- sp->save.a->dims = (unsigned int*)malloc(a->rank * sizeof(unsigned int));
- if (sp->save.a->dims == NULL) lose(E222, lineno, (char *)NULL);
- memcpy((char*)sp->save.a->dims, (char*)a->dims,
- a->rank * sizeof(unsigned int));
- prod = a->rank ? 1 : 0;
- for (i = 0 ; i < a->rank ; i++) {
- prod *= a->dims[i];
- }
- if (type == TAIL) {
- sp->save.a->data.tail =
- (type16*)malloc(prod * sizeof(type16));
- if (sp->save.a->data.tail == NULL) lose(E222, lineno, (char *)NULL);
- memcpy((char *)sp->save.a->data.tail,
- (char*)a->data.tail, prod * sizeof(type16));
- }
- else {
- sp->save.a->data.hybrid =
- (type32*)malloc(prod * sizeof(type32));
- if (sp->save.a->data.hybrid == NULL) lose(E222, lineno, (char *)NULL);
- memcpy((char *)sp->save.a->data.hybrid,
- (char*)a->data.hybrid, prod * sizeof(type32));
- }
- }
- return;
-}
-
-void retrieve(void *to, int type, unsigned int index, bool forget)
-/* restore the value of a variable from the save stack */
-{
- stashbox *sp;
-
- if ((sp = fetch(type, index)) == (stashbox *)NULL)
- lose(E436, lineno, (char *)NULL);
- else if (!forget) {
- if (type == ONESPOT)
- memcpy(to, (char *)&sp->save.onespot, sizeof(type16));
- else if (type == TWOSPOT)
- memcpy(to, (char *)&sp->save.twospot, sizeof(type32));
- else if (type == TAIL || type == HYBRID) {
- array *a = (array*)to;
- if (a->rank) {
- free(a->dims);
- if (type == TAIL)
- free(a->data.tail);
- else
- free(a->data.hybrid);
- memcpy(to, (char*)sp->save.a, sizeof(array));
- }
- free(sp->save.a);
- }
- }
- else if (type == TAIL || type == HYBRID) {
- free(sp->save.a->dims);
- if (type == TAIL)
- free(sp->save.a->data.tail);
- else
- free(sp->save.a->data.hybrid);
- free(sp->save.a);
- }
- free(sp);
-}
-
-/**********************************************************************
- *
- * The following function is used for random decision making
- *
- *********************************************************************/
-
-unsigned int roll(unsigned int n)
-/* return TRUE on n% chance, FALSE otherwise */
-{
-#ifdef USG
- return((unsigned int)(lrand48() % 100) < n);
-#else
- return((unsigned int)(rand() % 100) < n);
-#endif /* UNIX */
-}
-
-/* cesspool.c ends here */
+++ /dev/null
-/****************************************************************************
-
-NAME
- feh.c -- code-generator back-end for ick parser
-
-DESCRIPTION
- This module provides storage manglement, code degeneration,
-and optimizations of dubious value for the INTERCAL compiler.
-
-LICENSE TERMS
- Copyright (C) 1996 Eric S. Raymond
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-****************************************************************************/
-/*LINTLIBRARY */
-#include <stdio.h>
-#include <stdlib.h>
-#include <string.h>
-#include "sizes.h"
-#include "ick.h"
-#include "y.tab.h"
-#include "fiddle.h"
-#include "lose.h"
-#include "feh.h"
-
-static int emitlineno; /* line number for errors encountered during emit */
-
-/*************************************************************************
- *
- * Node allocation functions.
- *
- * Nodes are used to represent expresion trees. The emit() function
- * deallocates them.
- *
- **************************************************************************/
-
-node *newnode(void)
-/* allocate and zero out a new expression node */
-{
- return((node *)calloc(sizeof(node), 1));
-}
-
-node *cons(int type, node *car, node *cdr)
-{
- node *np = newnode();
-
- np->opcode = type;
- np->lval = car;
- np->rval = cdr;
-
- return(np);
-}
-
-/*************************************************************************
- *
- * Variable-name mapping
- *
- * This permits us to optimize use of variable storage at runtime
- *
- **************************************************************************/
-
-unsigned int intern(int type, int index)
-{
- atom *x;
-
- if (index < 1 || index > 65535)
- lose(E200, yylineno, (char *)NULL);
-
- if (!oblist)
- {
- /* initialize oblist and obdex */
- oblist = malloc(ALLOC_CHUNK * sizeof(atom));
- if (!oblist)
- lose(E778, yylineno, (char *)NULL);
- obdex = oblist;
- obcount = ALLOC_CHUNK;
- }
-
- /* if it's already on the oblist, return its intindex */
- for (x = oblist; x < obdex; x++)
- if (x->type == type && x->extindex == index)
- return(x->intindex);
-
- /* else we must intern a new symbol */
- if (obdex >= oblist + obcount)
- {
- obcount += ALLOC_CHUNK;
- x = realloc(oblist, obcount * sizeof(atom));
- if (!x)
- lose(E333, yylineno, (char *)NULL);
- obdex = x + (obdex - oblist);
- oblist = x;
- }
- obdex->type = type;
- obdex->extindex = index;
- if (type == ONESPOT)
- obdex->intindex = nonespots++;
- if (type == TWOSPOT)
- obdex->intindex = ntwospots++;
- if (type == TAIL)
- obdex->intindex = ntails++;
- if (type == HYBRID)
- obdex->intindex = nhybrids++;
- ++obdex;
-
- return(obdex[-1].intindex);
-}
-
-/*************************************************************************
- *
- * This function insures a label is valid.
- *
- **************************************************************************/
-
-void checklabel(int label)
-{
- if (label < 1 || label > 65535)
- lose(E197, yylineno, (char *)NULL);
-}
-
-/*************************************************************************
- *
- * Tuple allocation functions.
- *
- **************************************************************************/
-
-void treset(void)
-{
- tuplecount = 0;
- if (tuples)
- {
- free(tuples);
- tuples = NULL;
- }
- nonespots = ntwospots = ntails = nhybrids = 0;
- obdex = oblist;
- lineno = 0;
-}
-
-tuple *newtuple(void)
-/* allocate and zero out a new expression tuple */
-{
- if (lineno >= tuplecount)
- {
- tuplecount += ALLOC_CHUNK;
- if (tuples)
- tuples = realloc(tuples, tuplecount * sizeof(tuple));
- else
- tuples = malloc(tuplecount * sizeof(tuple));
- if (!tuples)
- {
- lose(E666, yylineno, (char *)NULL);
- return NULL;
- }
- memset(tuples + lineno, 0, (tuplecount - lineno) * sizeof(tuple));
- }
- return(tuples + lineno++);
-}
-
-/*************************************************************************
- *
- * The typecaster
- *
- * The theory here is that we associate a type with each node in order to
- * know what widths of unary-logical operator to use.
- *
- **************************************************************************/
-
-void typecast(node *np)
-{
- /* recurse so we typecast each node after all its subnodes */
- if (np == (node *)NULL)
- return;
- else if (np->lval != (node *)NULL)
- typecast(np->lval);
- if (np->rval != (node *)NULL)
- typecast(np->rval);
-
- /*
- * This is an entire set of type-deducing machinery right here.
- */
- if (np->opcode == MESH || np->opcode == ONESPOT || np->opcode == TAIL)
- np->width = 16;
- else if (np->opcode == TWOSPOT || np->opcode == HYBRID
- || np->opcode == MINGLE || np->opcode == MESH32)
- np->width = 32;
- else if (np->opcode == AND || np->opcode == OR || np->opcode == XOR ||
- np->opcode == FIN ||
- (np->opcode >= WHIRL && np->opcode <= WHIRL5))
- np->width = np->rval->width;
- else if (np->opcode == SELECT)
- np->width = np->rval->width; /* n-bit select has an n-bit result */
- else if (np->opcode == SUB)
- np->width = np->lval->width; /* type of the array */
-}
-
-/*************************************************************************
- *
- * The codechecker
- *
- * This checks for nasties like mismatched types in assignments that
- * can be detected at compile time -- also for errors that could cause
- * the compilation of the generated C to fail, like generated gotos to
- * nonexistent labels or duplicate labels.
- *
- **************************************************************************/
-
-void codecheck(void)
-{
- tuple *tp, *up;
-
- /* check for assignment type mismatches */
- /* This check can't be done at compile time---RTFM. [LHH] */
-/*
- for (tp = tuples; tp < tuples + lineno; tp++)
- if (tp->type == GETS)
- if (tp->u.node->lval->width == 16 && tp->u.node->rval->width == 32)
- lose(E275, tp - tuples + 1, (char *)NULL);
-*/
-
- /* check for duplicate labels */
- for (tp = tuples; tp < tuples + lineno; tp++)
- if (tp->label)
- for (up = tuples; up < tuples + lineno; up++)
- if (tp != up && tp->label == up->label)
- lose(E182, tp - tuples + 1, (char *)NULL);
-
- /*
- * Check that every NEXT, ABSTAIN, REINSTATE and COME_FROM actually has a
- * legitimate target label.
- */
- for (tp = tuples; tp < tuples + lineno; tp++)
- if (tp->type == NEXT
- || tp->type == ABSTAIN || tp->type == REINSTATE
- || tp->type == COME_FROM)
- {
- bool foundit = FALSE;
-
- for (up = tuples; up < tuples + lineno; up++)
- if (tp->u.target == up->label)
- {
- foundit = TRUE;
- break;
- }
-
- if (!foundit)
- {
- if (tp->type == NEXT)
- lose(E129, tp - tuples + 1, (char *)NULL);
- else if (tp->type == COME_FROM)
- lose(E444, tp - tuples + 1, (char *)NULL);
- else
- lose(E139, tp - tuples + 1, (char *)NULL);
- }
- /* tell the other tuple if it is a COME FROM target */
- else if (tp->type == COME_FROM)
- {
- if (up->comefrom)
- lose(E555, yylineno, (char *)NULL);
- else
- up->comefrom = tp - tuples + 1;
- }
- /* this substitutes line numbers for label numbers */
- else if (tp->type != NEXT)
- {
- tp->u.target = up - tuples + 1;
- }
- }
-}
-
-/*************************************************************************
- *
- * Optimizer code.
- *
- * It's not a very good optimizer, is it?
- *
- **************************************************************************/
-
-void optimize(node *np)
-{
- node *mingleop, *op;
-
- /* recurse so we simplify each node after all its subnodes */
- if (np == (node *)NULL)
- return;
- else if (np->lval != (node *)NULL)
- optimize(np->lval);
- if (np->rval != (node *)NULL)
- optimize(np->rval);
-
- /*
- * OK, now do complete folding of constant expressions.
- */
-
- /* fold MINGLE operations on constants */
- if (np->opcode==MINGLE && (np->lval->opcode==MESH&&np->rval->opcode==MESH))
- {
- np->opcode = MESH32;
- np->constant = mingle(np->lval->constant, np->rval->constant);
- free(np->lval);
- free(np->rval);
- }
-
- /* fold SELECT operations on constants */
- if (np->opcode == SELECT
- && ((np->lval->opcode==MESH || np->lval->opcode==MESH32)
- && (np->rval->opcode==MESH || np->rval->opcode==MESH32)))
- {
- np->opcode = np->rval->opcode;
- np->constant = iselect(np->lval->constant, np->rval->constant);
- free(np->lval);
- free(np->rval);
- }
-
- /* fold AND operations on 16-bit constants */
- if (np->opcode == AND && np->rval->opcode == MESH)
- {
- np->opcode = MESH;
- np->constant = and16(np->rval->constant);
- free(np->rval);
- }
-
- /* fold AND operations on 32-bit constants */
- if (np->opcode == AND && np->rval->opcode == MESH32)
- {
- np->opcode = MESH32;
- np->constant = and32(np->rval->constant);
- free(np->rval);
- }
-
- /* fold OR operations on 16-bit constants */
- if (np->opcode == OR && np->rval->opcode == MESH)
- {
- np->opcode = MESH;
- np->constant = or16(np->rval->constant);
- free(np->rval);
- }
-
- /* fold OR operations on 32-bit constants */
- if (np->opcode == OR && np->rval->opcode == MESH32)
- {
- np->opcode = MESH32;
- np->constant = or32(np->rval->constant);
- free(np->rval);
- }
-
- /* fold XOR operations on 16-bit constants */
- if (np->opcode == XOR && np->rval->opcode == MESH)
- {
- np->opcode = MESH;
- np->constant = xor16(np->rval->constant);
- free(np->rval);
- }
-
- /* fold XOR operations on 32-bit constants */
- if (np->opcode == XOR && np->rval->opcode == MESH32)
- {
- np->opcode = MESH32;
- np->constant = xor32(np->rval->constant);
- free(np->rval);
- }
-
- /*
- * Less trivial stuff begins here
- */
-
- /* following optimizations only work in binary */
- if (Base != 2)
- return;
-
- /* recognize the idioms for various C binary logical operations */
- if (np->opcode == SELECT
- && np->rval->opcode == MESH32 && np->rval->constant == 0x55555555
- && (op = np->lval)
- && (op->opcode == AND || op->opcode == OR || op->opcode == XOR)
- && (mingleop = op->rval) && mingleop->opcode == MINGLE
- && mingleop->rval->width == 16
- && mingleop->lval->width == 16)
- {
- np->lval = mingleop->lval;
- np->rval = mingleop->rval;
-
- switch(op->opcode)
- {
- case AND: np->opcode = C_AND; break;
- case OR: np->opcode = C_OR; break;
- case XOR: np->opcode = C_XOR; break;
- default: lose(E778, yylineno, (char *)NULL);
- }
-
- free(mingleop); free(op);
- }
-
- /* recognize idioms for ~ */
- if (np->opcode == C_XOR)
- {
- if (np->rval->width == 16
- && np->lval->opcode == MESH &&np->lval->constant == 0xffff)
- {
- np->opcode = C_NOT;
- free(np->lval);
- }
-
- if (np->lval->width == 16
- && np->rval->opcode == MESH && np->rval->constant == 0xffff)
- {
- np->opcode = C_NOT;
- free(np->rval);
- np->rval = np->lval;
- }
-
- if (np->rval->width == 32
- && np->lval->opcode == MESH32 && np->lval->constant == 0xffffffffL)
- {
- np->opcode = C_NOT;
- free(np->lval);
- }
-
- if (np->lval->width == 32
- && np->rval->opcode == MESH32 && np->rval->constant == 0xffffffffL)
- {
- np->opcode = C_NOT;
- free(np->rval);
- np->rval = np->lval;
- }
- }
-}
-
-/*************************************************************************
- *
- * Code degeneration
- *
- * The theory behind this crock is that we've been handed a pointer to
- * a tuple representing a single INTERCAL statement, possibly with an
- * expression tree hanging off it and twisting slowly, slowly in the wind.
- *
- * Our mission, should we choose to accept it, is to emit C code which,
- * when linked to the INTERCAL run-time support, will do something
- * resembling the right thing.
- *
- **************************************************************************/
-
-/*
- * If the order of statement-token defines in ick.y ever changes,
- * this will need to be reordered.
- */
-char *enablers[MAXTYPES] =
-{
- "GETS",
- "RESIZE",
- "NEXT",
- "FORGET",
- "RESUME",
- "STASH",
- "RETRIEVE",
- "IGNORE",
- "REMEMBER",
- "ABSTAIN",
- "REINSTATE",
- "DISABLE",
- "ENABLE",
- "GIVE_UP",
- "READ_OUT",
- "WRITE_IN",
- "COME_FROM",
-};
-
-assoc vartypes[] =
-{
- { ONESPOT, "ONESPOT" },
- { TWOSPOT, "TWOSPOT" },
- { TAIL, "TAIL" },
- { HYBRID, "HYBRID" },
- { 0, (char *)NULL }
-};
-
-static assoc forgetbits[] =
-{
- { ONESPOT, "oneforget" },
- { TWOSPOT, "twoforget" },
- { TAIL, "tailforget" },
- { HYBRID, "hyforget" },
- { 0, (char *)NULL }
-};
-
-static assoc varstores[] =
-{
- { ONESPOT, "onespots" },
- { TWOSPOT, "twospots" },
- { TAIL, "tails" },
- { HYBRID, "hybrids" },
- { 0, (char *)NULL }
-};
-
-static assoc typedefs[] =
-{
- { ONESPOT, "type16" },
- { TWOSPOT, "type32" },
- { TAIL, "type16" },
- { HYBRID, "type32" },
- { 0, (char *)NULL }
-};
-
-char *nameof(int value, assoc table[])
-/* return string corresponding to value in table */
-{
- assoc *ap;
-
- for (ap = table; ap->name; ap++)
- if (ap->value == value)
- return(ap->name);
- return((char *)NULL);
-}
-
-static void prexpr(node *np, FILE *fp);
-
-static void prvar(node *np, FILE *fp)
-/* print out args to pass to storage manager for reference */
-{
- node *sp;
- int dim;
-
- switch (np->opcode)
- {
- case ONESPOT:
- (void) fprintf(fp, "onespots[%lu]", np->constant);
- break;
-
- case TWOSPOT:
- (void) fprintf(fp, "twospots[%lu]", np->constant);
- break;
-
- case TAIL:
- (void) fprintf(fp, "TAIL, &tails[%lu]", np->constant);
- break;
-
- case HYBRID:
- (void) fprintf(fp, "HYBRID, &hybrids[%lu]", np->constant);
- break;
-
- case SUB:
- {
- (void) fprintf(fp, "aref(");
- prvar(np->lval, fp);
-
- dim = 0;
- for (sp = np->rval ; sp ; sp = sp->rval)
- dim++;
- (void) fprintf(fp, ", %d", dim);
-
- for (sp = np->rval ; sp ; sp = sp->rval) {
- (void) fprintf(fp, ", ");
- prexpr(sp->lval, fp);
- }
- (void) fprintf(fp, ")");
- }
- break;
- }
-}
-
-static void prexpr(node *np, FILE *fp)
-/* print out C-function equivalent of an expression */
-{
- switch (np->opcode)
- {
- case MINGLE:
- (void) fprintf(fp, "mingle(");
- prexpr(np->lval, fp);
- (void) fprintf(fp, ", ");
- prexpr(np->rval, fp);
- (void) fprintf(fp, ")");
- break;
-
- case SELECT:
- (void) fprintf(fp, "iselect(");
- prexpr(np->lval, fp);
- (void) fprintf(fp, ", ");
- prexpr(np->rval, fp);
- (void) fprintf(fp, ")");
- break;
-
- case AND:
- (void) fprintf(fp, "and%d(", np->width);
- prexpr(np->rval, fp);
- (void) fprintf(fp, ")");
- break;
-
- case OR:
- (void) fprintf(fp, "or%d(", np->width);
- prexpr(np->rval, fp);
- (void) fprintf(fp, ")");
- break;
-
- case XOR:
- (void) fprintf(fp, "xor%d(", np->width);
- prexpr(np->rval, fp);
- (void) fprintf(fp, ")");
- break;
-
- case FIN:
- if (Base < 3)
- lose(E997, emitlineno, (char *)NULL);
- (void) fprintf(fp, "fin%d(", np->width);
- prexpr(np->rval, fp);
- (void) fprintf(fp, ")");
- break;
-
- case WHIRL:
- case WHIRL2:
- case WHIRL3:
- case WHIRL4:
- case WHIRL5:
- if (np->opcode - WHIRL + 3 > Base)
- lose(E997, emitlineno, (char *)NULL);
- (void) fprintf(fp, "whirl%d(%d, ", np->width, np->opcode - WHIRL + 1);
- prexpr(np->rval, fp);
- (void) fprintf(fp, ")");
- break;
-
- case MESH:
- (void) fprintf(fp, "0x%lx", np->constant);
- break;
-
- case MESH32:
- (void) fprintf(fp, "0x%lx", np->constant);
- break;
-
- case ONESPOT:
- case TWOSPOT:
- case TAIL:
- case HYBRID:
- prvar(np, fp);
- break;
-
- case SUB:
- (void) fprintf(fp, "*(%s*)", nameof(np->lval->opcode, typedefs));
- prvar(np, fp);
- break;
-
- /* cases from here down are generated by the optimizer */
- case C_AND:
- (void) fprintf(fp, "(");
- prexpr(np->lval, fp);
- (void) fprintf(fp, " & ");
- prexpr(np->rval, fp);
- (void) fprintf(fp, ")");
- break;
-
- case C_OR:
- (void) fprintf(fp, "(");
- prexpr(np->lval, fp);
- (void) fprintf(fp, " | ");
- prexpr(np->rval, fp);
- (void) fprintf(fp, ")");
- break;
-
- case C_XOR:
- (void) fprintf(fp, "(");
- prexpr(np->lval, fp);
- (void) fprintf(fp, " ^ ");
- prexpr(np->rval, fp);
- (void) fprintf(fp, ")");
- break;
-
- case C_NOT:
- (void) fprintf(fp, "(~");
- prexpr(np->rval, fp);
- if (np->rval->width == Small_digits)
- (void) fprintf(fp, " & Max_small)");
- else
- (void) fprintf(fp, " & Max_large)");
- break;
- }
-
- (void) free(np);
-}
-
-static char *nice_text(char *texts[], int lines)
-{
-#define MAXNICEBUF 512
- static char buf[MAXNICEBUF];
- char *cp, *text;
- int i;
-
- if (lines < 1)
- lines = 1;
- for (cp = buf, i = 0 ; i < lines ; ++i) {
- if (cp>buf+MAXNICEBUF-10) goto abort;
- if (i) {
- (*cp++) = '\\';
- (*cp++) = 'n';
- (*cp++) = '\\';
- (*cp++) = '\n';
- (*cp++) = '\t';
- }
- for (text = texts[i] ; *text ; cp++, text++) {
- if (cp>buf+MAXNICEBUF-10) goto abort;
- if(*text == '"' || *text == '\\') {
- (*cp++) = '\\';
- }
- *cp = *text;
- }
- }
- *cp = '\0';
- return buf;
-abort: (*cp++) = '.';
- (*cp++) = '.';
- (*cp++) = '.';
- *cp = '\0';
- return buf;
-}
-
-static void emit_guard(tuple *tn, FILE *fp)
-/* emit execution guard for giiven tuple (note the unbalanced trailing {!) */
-{
- (void) fprintf(fp, " if (");
- if (tn->exechance < 100)
- (void) fprintf(fp, "roll(%d) && ", tn->exechance);
- (void) fprintf(fp, "!abstained[%d]) {\n", (int)(tn - tuples));
-}
-
-void emit(tuple *tn, FILE *fp)
-/* emit code for the given tuple */
-{
- node *np, *sp;
- int dim;
-
- /* grind out label and source dump */
- if (yydebug || compile_only)
- (void) fprintf(fp, " /* line %03d */\n", tn->lineno);
- if (tn->label)
- (void) fprintf(fp, "L%d:", tn->label);
- if (yydebug || compile_only)
- (void) fprintf(fp, "\t/* %s */", textlines[tn->lineno]);
- (void) fputc('\n', fp);
-
- /* set up the "next" lexical line number for error messages */
- if (tn->type == NEXT) {
- tuple *up;
- for (up = tuples; up < tuples + lineno; up++)
- if (tn->u.target == up->label) {
- emitlineno = up->lineno;
- break;
- }
- } else if (tn->comefrom)
- emitlineno = tuples[tn->comefrom-1].lineno;
- else if (tn < tuples + lineno - 1)
- emitlineno = tn[1].lineno;
- else
- emitlineno = yylineno;
- (void) fprintf(fp, " lineno = %d;\n", emitlineno);
-
- /* emit conditional-execution prefixes */
- if (tn->type != COME_FROM)
- emit_guard(tn, fp);
-
- /* now emit the code for the statement body */
- switch(tn->type)
- {
- case GETS:
- np = tn->u.node;
- if (np->lval->opcode != SUB) {
- sp = np->lval;
- (void) fprintf(fp,"\t(void) assign((char*)&");
- }
- else {
- sp = np->lval->lval;
- (void) fprintf(fp,"\t(void) assign(");
- }
- prvar(np->lval, fp);
- (void) fprintf(fp,", %s", nameof(sp->opcode, vartypes));
- (void) fprintf(fp,", %s[%lu], ", nameof(sp->opcode, forgetbits),
- sp->constant);
- prexpr(np->rval, fp);
- (void) fprintf(fp,");\n");
- break;
-
- case RESIZE:
- np = tn->u.node;
- dim = 0;
- for (sp = np->rval; sp; sp = sp->rval)
- dim++;
- (void) fprintf(fp, "\tresize(");
- prvar(np->lval, fp);
- (void) fprintf(fp, ", %s[%lu]", nameof(np->lval->opcode, forgetbits),
- np->lval->constant);
- (void) fprintf(fp, ", %d", dim);
- for (sp = np->rval; sp; sp = sp->rval) {
- (void) fprintf(fp, ", ");
- prexpr(sp->lval, fp);
- }
- (void) fprintf(fp, ");\n");
- break;
-
- case NEXT:
- (void) fprintf(fp,
- "\tpushnext(%d); goto L%d; N%d:;\n",
- (int)(tn - tuples + 1), tn->u.target, (int)(tn - tuples + 1));
- break;
-
- case RESUME:
- (void) fprintf(fp, "\tskipto = resume(");
- prexpr(tn->u.node, fp);
- (void) fprintf(fp, "); goto top;\n");
- break;
-
- case FORGET:
- (void) fprintf(fp, "\tpopnext(");
- prexpr(tn->u.node, fp);
- (void) fprintf(fp, ");\n");
- break;
-
- case STASH:
- for (np = tn->u.node; np; np = np->rval)
- (void) fprintf(fp, "\tstash(%s, %lu, %s+%lu);\n",
- nameof(np->opcode, vartypes),
- np->constant,
- nameof(np->opcode, varstores), np->constant);
- break;
-
- case RETRIEVE:
- for (np = tn->u.node; np; np = np->rval)
- (void) fprintf(fp, "\tretrieve(%s+%lu, %s, %lu, %s[%lu]);\n",
- nameof(np->opcode, varstores), np->constant,
- nameof(np->opcode, vartypes),
- np->constant,
- nameof(np->opcode, forgetbits),
- np->constant);
- break;
-
- case IGNORE:
- for (np = tn->u.node; np; np = np->rval)
- (void) fprintf(fp,"\t%s[%lu] = TRUE;\n",
- nameof(np->opcode, forgetbits),
- np->constant);
- break;
-
- case REMEMBER:
- for (np = tn->u.node; np; np = np->rval)
- (void) fprintf(fp,"\t%s[%lu] = FALSE;\n",
- nameof(np->opcode, forgetbits),
- np->constant);
- break;
-
- case ABSTAIN:
- (void) fprintf(fp, "\tabstained[%d] = TRUE;\n", tn->u.target - 1);
- break;
-
- case REINSTATE:
- (void) fprintf(fp, "\tabstained[%d] = FALSE;\n", tn->u.target - 1);
- break;
-
- case ENABLE:
- (void) fprintf(fp,
- "\tint i;\n");
- for (np = tn->u.node; np; np = np->rval)
- {
- (void) fprintf(fp,
- "\n\tfor (i = 0; i < (int)(sizeof(linetype)/sizeof(int)); i++)\n");
- if (np->constant == ABSTAIN || np->constant == REINSTATE) {
- (void) fprintf(fp,
- "\t if (linetype[i] == %s || linetype[i] == %s)\n", enablers[np->constant-GETS], enablers[np->constant-GETS+2]);
- } else {
- (void) fprintf(fp,
- "\t if (linetype[i] == %s)\n", enablers[np->constant-GETS]);
- }
- (void) fprintf(fp,
- "\t\tabstained[i] = FALSE;\n");
- }
- break;
-
- case DISABLE:
- (void) fprintf(fp,
- "\tint i;\n");
- for (np = tn->u.node; np; np = np->rval)
- {
- (void) fprintf(fp,
- "\n\tfor (i = 0; i < (int)(sizeof(linetype)/sizeof(int)); i++)\n");
- if (np->constant == ABSTAIN || np->constant == REINSTATE) {
- (void) fprintf(fp,
- "\t if (linetype[i] == %s || linetype[i] == %s)\n", enablers[np->constant-GETS], enablers[np->constant-GETS+2]);
- } else {
- (void) fprintf(fp,
- "\t if (linetype[i] == %s)\n", enablers[np->constant-GETS]);
- }
- (void) fprintf(fp,
- "\t\tabstained[i] = TRUE;\n");
- }
- break;
-
- case GIVE_UP:
- (void) fprintf(fp, "\treturn(0);\n");
- break;
-
- case WRITE_IN:
- for (np = tn->u.node; np; np = np->rval) {
- if (np->lval->opcode == TAIL || np->lval->opcode == HYBRID) {
- (void) fprintf(fp,"\tbinin(");
- prvar(np->lval, fp);
- (void) fprintf(fp, ", %s[%lu]",
- nameof(np->lval->opcode, forgetbits),
- np->lval->constant);
- (void) fprintf(fp,");\n");
- }
- else {
- if (np->lval->opcode != SUB) {
- sp = np->lval;
- (void) fprintf(fp,"\t(void) assign((char*)&");
- }
- else {
- sp = np->lval->lval;
- (void) fprintf(fp,"\t(void) assign(");
- }
- prvar(np->lval, fp);
- (void) fprintf(fp,", %s", nameof(sp->opcode, vartypes));
- (void) fprintf(fp,", %s[%lu]", nameof(sp->opcode, forgetbits),
- sp->constant);
- (void) fprintf(fp,", pin());\n");
- }
- }
- break;
-
- case READ_OUT:
- for (np = tn->u.node; np; np = np->rval)
- {
- if (np->lval->opcode == TAIL || np->lval->opcode == HYBRID) {
- (void) fprintf(fp,"\tbinout(");
- prvar(np->lval, fp);
- (void) fprintf(fp,");\n");
- }
- else {
- (void) fprintf(fp, "\tpout(");
- prexpr(np->lval, fp);
- (void) fprintf(fp, ");\n");
- }
- }
- break;
-
- case SPLATTERED:
- dim = emitlineno - tn->lineno;
- if (tn->sharedline)
- ++dim;
- (void) fprintf(fp, "\tlose(E000, %d, \"%s\");\n",
- emitlineno, nice_text(textlines + tn->lineno, dim));
- break;
-
- case COME_FROM:
- (void) fprintf(fp, "C%d:\n", tn->u.target);
- break;
-
- default:
- lose(E778, emitlineno, (char *)NULL);
- break;
- }
-
- if (tn->type != COME_FROM)
- (void) fprintf(fp, " }\n");
-
- /*
- * If the statement that was just degenerated was a COME FROM target,
- * emit the code for the jump to the COME FROM.
- */
- if (tn->comefrom) {
- if (yydebug || compile_only)
- (void) fprintf(fp,
- " /* line %03d is a suck point for the COME FROM at line %03d */\n",
- tn->lineno, tuples[tn->comefrom-1].lineno);
- emit_guard(tuples + tn->comefrom - 1, fp);
- (void) fprintf(fp,
- "\tgoto C%d;\n }\n",
- tuples[tn->comefrom-1].u.target);
- }
-}
-
-/* feh.c ends here */
+++ /dev/null
-/* feh.h -- compilation functions used by perpetrate.c and ick.y */
-
-extern node *newnode(void);
-extern node *cons(int type, node *car, node *cdr);
-extern unsigned int intern(int type, int index);
-extern void checklabel(int label);
-extern void treset(void);
-extern tuple *newtuple(void);
-extern void typecast(node *np);
-extern void codecheck(void);
-extern void optimize(node *np);
-extern char *nameof(int value, assoc table[]);
-extern void emit(tuple *tn, FILE *fp);
-
-extern char *enablers[MAXTYPES];
-extern assoc vartypes[];
-
-/* feh.h ends here */
+++ /dev/null
-/*
- * fiddle.c -- functions that implement the five INTERCAL operators
- *
- * We link these to the compiler, too, in order to do constant folding
- *
-LICENSE TERMS
- Copyright (C) 1996 Eric S. Raymond
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- */
-
-#include "fiddle.h"
-#include "sizes.h"
-
-unsigned int mingle(register unsigned int r, register unsigned int s)
-{
- if (Base == 2) {
- r = ((r & 0x0000ff00) << 8) | (r & 0x000000ff);
- r = ((r & 0x00f000f0) << 4) | (r & 0x000f000f);
- r = ((r & 0x0c0c0c0c) << 2) | (r & 0x03030303);
- r = ((r & 0x22222222) << 1) | (r & 0x11111111);
- s = ((s & 0x0000ff00) << 8) | (s & 0x000000ff);
- s = ((s & 0x00f000f0) << 4) | (s & 0x000f000f);
- s = ((s & 0x0c0c0c0c) << 2) | (s & 0x03030303);
- s = ((s & 0x22222222) << 1) | (s & 0x11111111);
- return (r << 1) | s;
- }
- else {
- unsigned int result = 0, fac = 1;
- int i;
- for (i = 0 ; i < Small_digits ; i++) {
- result += fac * (s % Base);
- s /= Base;
- fac *= Base;
- result += fac * (r % Base);
- r /= Base;
- fac *= Base;
- }
- return result;
- }
-}
-
-unsigned int iselect(register unsigned int r, register unsigned int s)
-{
- if (Base == 2) {
- register unsigned int i = 1, t = 0;
- while (s) {
- if (s & i) {
- t |= r & i;
- s ^= i;
- i <<= 1;
- }
- else {
- s >>= 1;
- r >>= 1;
- }
- }
- return(t);
- }
- else {
- unsigned int j, result = 0, fac, digit, ofac = 1;
- for (j = Base - 1 ; j > 0 ; j--) {
- int i;
- fac = 1;
- for (i = 0; i < Large_digits ; i++) {
- if ((s / fac) % Base == j) {
- digit = (r / fac) % Base;
- if (digit)
- result += ofac * (digit > j ? digit : j);
- ofac *= Base;
- }
- fac *= Base;
- }
- }
- return result;
- }
-}
-
-static unsigned int whirl(unsigned int len, unsigned int p, unsigned int n)
-{
- unsigned int i, fac = 1, result = 0, d1, d2, dsave;
- d1 = n % Base;
- dsave = d1;
- for (i = 1 ; i <= len ; i++) {
- d2 = d1;
- d1 = (i < len) ? (n /= Base, n % Base) : dsave;
- if (d1 <= p)
- result += fac * ((d2 < d1 || d2 > p) ? d1 : d2);
- else
- result += fac * ((d2 < d1 && d2 > p) ? d1 : d2);
- fac *= Base;
- }
- return result;
-}
-
-unsigned int and16(unsigned int n)
-{
- if (Base == 2) {
- unsigned int m = (n >> 1);
- if (n & 1)
- m |= 0x8000;
- return(m & n);
- }
- else {
- return whirl(Small_digits,0,n);
- }
-}
-
-unsigned int or16(unsigned int n)
-{
- if (Base == 2) {
- unsigned int m = (n >> 1);
- if (n & 1)
- m |= 0x8000;
- return(m | n);
- }
- else {
- return whirl(Small_digits,Base-1,n);
- }
-}
-
-unsigned int whirl16(unsigned int p, unsigned int n)
-{
- return whirl(Small_digits,p,n);
-}
-
-unsigned int and32(unsigned int n)
-{
- if (Base == 2) {
- unsigned int m = (n >> 1);
- if (n & 1)
- m |= 0x80000000;
- return(m & n);
- }
- else {
- return whirl(Large_digits,0,n);
- }
-}
-
-unsigned int or32(unsigned int n)
-{
- if (Base == 2) {
- unsigned int m = (n >> 1);
- if (n & 1)
- m |= 0x80000000;
- return(m | n);
- }
- else {
- return whirl(Large_digits,Base-1,n);
- }
-}
-
-unsigned int whirl32(unsigned int p, unsigned int n)
-{
- return whirl(Large_digits,p,n);
-}
-
-unsigned int xor(unsigned int len, unsigned int n)
-{
- unsigned int i, fac = 1, result = 0, d1, d2, dsave;
- d1 = n % Base;
- dsave = d1;
- for (i = 1 ; i <= len ; i++) {
- d2 = d1;
- d1 = (i < len) ? (n /= Base, n % Base) : dsave;
- result += fac * ((Base + d1 - d2) % Base);
- fac *= Base;
- }
- return result;
-}
-
-unsigned int xor16(unsigned int n)
-{
- if (Base == 2) {
- unsigned int m = (n >> 1);
- if (n & 1)
- m |= 0x8000;
- return(m ^ n);
- }
- else {
- return xor(Small_digits,n);
- }
-}
-
-unsigned int xor32(unsigned int n)
-{
- if (Base == 2) {
- unsigned int m = (n >> 1);
- if (n & 1)
- m |= 0x80000000;
- return(m ^ n);
- }
- else {
- return xor(Large_digits,n);
- }
-}
-
-static unsigned int fin(unsigned int len, unsigned int n)
-{
- unsigned int i, fac = 1, result = 0, d1, d2, dsave;
- d1 = n % Base;
- dsave = d1;
- for (i = 1 ; i <= len ; i++) {
- d2 = d1;
- d1 = (i < len) ? (n /= Base, n % Base) : dsave;
- result += fac * ((d1 + d2) % Base);
- fac *= Base;
- }
- return result;
-}
-
-unsigned int fin16(unsigned int n)
-{
- if (Base == 2) {
- unsigned int m = (n >> 1);
- if (n & 1)
- m |= 0x8000;
- return(m ^ n);
- }
- else {
- return fin(Small_digits,n);
- }
-}
-
-unsigned int fin32(unsigned int n)
-{
- if (Base == 2) {
- unsigned int m = (n >> 1);
- if (n & 1)
- m |= 0x80000000;
- return(m ^ n);
- }
- else {
- return fin(Large_digits,n);
- }
-}
-
-/* fiddle.c */
+++ /dev/null
-/* fiddle.h -- functions implementing intercal's operators */
-
-extern unsigned int mingle(register unsigned int r, register unsigned int s);
-extern unsigned int iselect(register unsigned int r, register unsigned int s);
-extern unsigned int and16(unsigned int n), or16(unsigned int n),
- xor16(unsigned int n), fin16(unsigned int n);
-extern unsigned int whirl16(unsigned int p, unsigned int n);
-extern unsigned int and32(unsigned int n), or32(unsigned int n),
- xor32(unsigned int n), fin32(unsigned int n);
-extern unsigned int whirl32(unsigned int p, unsigned int n);
-
-/* fiddle.h ends here */
+++ /dev/null
-/* $A.c -- generated C-code file for INTERCAL program $A.i */
-
-/* This code is explicitly *not* GPLed. Use, abuse, and redistribute freely */
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <time.h>
-
-#include <fiddle.h>
-#include <abcess.h>
-#include <lose.h>
-
-int lineno;
-
-static int abstained[$B]$C;
-$D
-$E
-
-int main(int argc, char *argv[])
-{
- int skipto = 0;
-
- parseargs(argc,argv);
-
- /* set seed for random error generation */
-#ifdef USG
- srand48(time((long *)0) + getpid());
-#else
- srand(time((long *)0));
-#endif /* UNIX */
-
- /* set up stash storage */
- stashinit();
-
- $F
- /* degenerated code */
-$G
- lose(E633, $J, (char *)0);
-
-$H
- return 0;
-}
-
-/* Generated code for $A.i ends here */
+++ /dev/null
-/* ick.h -- compilation types for intercal parser */
-
-/* Comment this out if your version of lex automatically supplies yylineno. */
-#define YYLINENO_BY_HAND
-
-/* Comment this out if your version of lex doesn't use yyrestart(). */
-#define USE_YYRESTART
-
-typedef int bool;
-#define TRUE 1
-#define FALSE 0
-
-#define ALLOC_CHUNK 256
-
-/*
- * We choose this value for maximum number of possible variables on
- * the theory that no human mind could grok a more complex INTERCAL
- * program than this and still retain any vestige of sanity.
-#define MAXVARS 100
- */
-
-/*
- * Maximum supported statement types; should be equal to (COME_FROM - GETS + 1)
- */
-#define MAXTYPES 17
-
-typedef struct node_t
-{
- int opcode; /* operator or type code */
- unsigned long constant; /* constant data attached */
- int width; /* is this 32-bit data? */
- struct node_t *lval, *rval; /* attached expression nodes */
-} node;
-
-typedef struct tuple_t
-{
- unsigned int label; /* label # of this statement */
- unsigned int comefrom; /* if NZ, a COME FROM touches this */
- int exechance; /* chance of execution */
- unsigned int type; /* statement type */
- union
- {
- unsigned int target; /* for NEXT statements */
- node *node; /* attached expression node(s) */
- } u;
- int lineno; /* source line for error messages */
- bool sharedline; /* if NZ, two statements on a line */
-} tuple;
-
-/* this maps the `external' name of a variable to an internal array index */
-typedef struct
-{
- int type;
- int extindex;
- int intindex;
-}
-atom;
-
-typedef struct
-{
- int value;
- char *name;
-}
-assoc;
-
-extern atom *oblist, *obdex;
-extern int obcount, nonespots, ntwospots, ntails, nhybrids;
-
-extern tuple *tuples;
-extern int tuplecount;
-
-extern char *enablers[MAXTYPES];
-extern assoc vartypes[];
-
-/* the lexical analyzer keeps copies of the source logical lines */
-extern char **textlines;
-extern int textlinecount;
-extern int yylineno;
-
-/* compilation options */
-extern bool compile_only; /* just compile into C, don't run the linker */
-extern bool nocompilerbug; /* set possibility of E774 to zero */
-extern int traditional; /* compile as INTERCAL-72 */
-extern int yydebug; /* print debugging information while parsing */
-
-extern int politesse;
-
-/* ick.h ends here */
+++ /dev/null
-/*****************************************************************************
-
-NAME
- ick.y -- grammar for the INTERCAL language
-
-DESCRIPTION
- This YACC grammar parses the INTERCAL language by designed by Don R. Woods
-and James M. Lyon. There are two syntax extensions over the original
-INTERCAL-72 language; the COME FROM statement, and the prefixed forms of the
-WHIRL operator.
-
-LICENSE TERMS
- Copyright (C) 1996 Eric S. Raymond
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-*****************************************************************************/
-
-%{
-#include <stdio.h>
-#include <stdlib.h>
-#include "sizes.h"
-#include "ick.h"
-#include "feh.h"
-#include "lose.h"
-
-extern int yyerror(char*);
-
-/* Intervene our first-stage lexer. */
-extern int lexer(void);
-#define yylex() lexer()
-
-static node *rlist; /* pointer to current right-hand node list */
-/*static node *llist;*/ /* pointer to current left-hand node list */
-static node *np; /* variable for building node lists */
-
-extern int stbeginline; /* line number of last seen preamble */
-static int thisline; /* line number of beginning of current statement */
-static tuple *splat(void);
-
-#define GETLINENO \
- {if (stbeginline < 0) thisline = -stbeginline; \
- else {thisline = stbeginline; stbeginline = 0;}}
-
-#define ACTION(x, nt, nn) \
- {x = newtuple(); x->type = nt; x->lineno = thisline; x->u.node = nn;}
-#define TARGET(x, nt, nn) \
- {x = newtuple(); x->type = nt; x->lineno = thisline; x->u.target = nn;}
-#define NEWFANGLED if (traditional) lose(E111,yylineno,(char*)NULL); else
-
-%}
-
-%start program
-
-%union
-{
- int numval; /* a numeric value */
- tuple *tuple; /* a code tuple */
- node *node; /* an expression-tree node */
-}
-
-/*
- * Don't change this statement token list gratuitously!
- * Some code in feh.c depends on GETS being the least
- * statement type and on the order of the ones following.
- */
-%token GETS RESIZE NEXT FORGET RESUME STASH RETRIEVE IGNORE REMEMBER ABSTAIN
-%token REINSTATE DISABLE ENABLE GIVE_UP READ_OUT WRITE_IN COME_FROM
-
-%token DO PLEASE NOT MESH ONESPOT TWOSPOT TAIL HYBRID
-%token MINGLE SELECT SPARK EARS SUB BY BADCHAR
-
-%token <numval> NUMBER UNARY OHOHSEVEN GERUND LABEL
-%token <node> INTERSECTION
-
-/*
- * These are not tokens returned by the lexer, but they are used as
- * tokens elsewhere. We define them here to insure that the values
- * will not conflict with the other tokens. It is important that
- * WHIRL through WHIRL5 be a continuous sequence.
- */
-%token SPLATTERED C_AND C_OR C_XOR C_NOT AND OR XOR FIN MESH32
-%token WHIRL WHIRL2 WHIRL3 WHIRL4 WHIRL5
-
-%type <node> expr varlist variable constant lvalue inlist outlist
-%type <node> subscr byexpr scalar array initem outitem sublist
-%type <node> unambig subscr1 sublist1 oparray osubscr osubscr1
-%type <tuple> perform
-%type <numval> please preftype
-
-%nonassoc HIGHPREC
-%nonassoc EARS SPARK
-
-%% /* beginning of rules section */
-
-/* A program description consists of a sequence of statements */
-program : /* EMPTY */
- | program command
- ;
-
-/*
- * Each command consists of an optional label, followed by a preamble,
- * followed by an optional probability, followed by the statement body.
- * Negative exechance values indicate initial abstentions, and will be
- * made positive before code is emitted.
- */
-command : please perform
- {$2->label = 0; $2->exechance = $1 * 100;}
- | please OHOHSEVEN perform
- {$3->label = 0; $3->exechance = $1 * $2;}
- | LABEL please perform
- {checklabel($1); $3->label = $1; $3->exechance = $2 * 100;}
- | LABEL please OHOHSEVEN perform
- {checklabel($1); $4->label = $1; $4->exechance = $2 * $3;}
- | error
- {lose(E017, yylineno, (char *)NULL);}
- ;
-
-/* There are two forms of preamble returned by the lexer */
-please : DO {GETLINENO; $$ = 1;}
- | DO NOT {GETLINENO; $$ = -1;}
- ;
-
-/* Here's how to parse statement bodies */
-perform : lvalue GETS expr {ACTION($$, GETS, cons(GETS,$1,$3));}
- | array GETS byexpr {ACTION($$, RESIZE, cons(RESIZE,$1,$3));}
- | LABEL NEXT {TARGET($$, NEXT, $1);}
- | FORGET expr {ACTION($$, FORGET, $2);}
- | RESUME expr {ACTION($$, RESUME, $2);}
- | STASH varlist {ACTION($$, STASH, rlist);}
- | RETRIEVE varlist {ACTION($$, RETRIEVE, rlist);}
- | IGNORE varlist {ACTION($$, IGNORE, rlist);}
- | REMEMBER varlist {ACTION($$, REMEMBER, rlist);}
- | ABSTAIN LABEL {stbeginline=0; TARGET($$, ABSTAIN, $2);}
- | ABSTAIN gerunds {ACTION($$, DISABLE, rlist);}
- | REINSTATE LABEL {stbeginline=0; TARGET($$, REINSTATE, $2);}
- | REINSTATE gerunds {ACTION($$, ENABLE, rlist);}
- | WRITE_IN inlist {ACTION($$, WRITE_IN, $2);}
- | READ_OUT outlist {ACTION($$, READ_OUT, $2);}
- | GIVE_UP {ACTION($$, GIVE_UP, 0);}
- | COME_FROM LABEL {NEWFANGLED {TARGET($$,COME_FROM,$2)}}
- | BADCHAR {yyclearin; $$ = splat();}
- | error {yyclearin; $$ = splat();}
- ;
-
-/* gerund lists are used by ABSTAIN and REINSTATE */
-gerunds : GERUND
- {rlist = np = newnode(); np->constant = $1;}
- | gerunds INTERSECTION GERUND
- {
- np->rval = newnode();
- np = np->rval;
- np->constant = $3;
- }
- ;
-
-/* OK, here's what a variable reference looks like */
-variable: scalar | array;
-
-lvalue : scalar | subscr;
-
-scalar : ONESPOT NUMBER
- {
- $$ = newnode();
- $$->opcode = ONESPOT;
- $$->constant = intern(ONESPOT, $2);
- }
- | TWOSPOT NUMBER
- {
- $$ = newnode();
- $$->opcode = TWOSPOT;
- $$->constant = intern(TWOSPOT, $2);
- }
- ;
-
-array : TAIL NUMBER
- {
- $$ = newnode();
- $$->opcode = TAIL;
- $$->constant = intern(TAIL, $2);
- }
- | HYBRID NUMBER
- {
- $$ = newnode();
- $$->opcode = HYBRID;
- $$->constant = intern(HYBRID, $2);
- }
- ;
-
-/* Array with unary operator is a special intermediate case; these
- nodes will be rearranged when the subscript list is added */
-oparray : TAIL UNARY NUMBER
- {
- $$ = newnode();
- $$->opcode = $2;
- $$->rval = newnode();
- $$->rval->opcode = TAIL;
- $$->rval->constant = intern(TAIL, $3);
- }
- | HYBRID UNARY NUMBER
- {
- $$ = newnode();
- $$->opcode = $2;
- $$->rval = newnode();
- $$->rval->opcode = HYBRID;
- $$->rval->constant = intern(HYBRID, $3);
- }
- ;
-
-/* And a constant looks like this */
-constant: MESH NUMBER
- {
- /* enforce the 16-bit constant constraint */
- if ((unsigned int)$2 > Max_small)
- lose(E017, yylineno, (char *)NULL);
- $$ = newnode();
- $$->opcode = MESH;
- $$->constant = $2;
- }
- ;
-
-/* variable lists are used in STASH, RETRIEVE, IGNORE, REMEMBER */
-varlist : variable {rlist = np = $1;}
- | varlist INTERSECTION variable {np = np->rval = $3;
- /* newnode(); */ }
- ;
-
-/* scalars and subscript exprs are permitted in WRITE IN lists */
-/* new: arrays are also permitted to allow for bitwise I/0 */
-initem : scalar | subscr | array;
-inlist : initem INTERSECTION inlist {$$=cons(INTERSECTION,$1,$3);}
- | initem {$$=cons(INTERSECTION,$1,0);}
-
-/* scalars, subscript exprs & constants are permitted in READ OUT lists */
-/* new: arrays are also permitted to allow for bitwise I/0 */
-outitem : scalar | subscr | constant | array;
-outlist : outitem INTERSECTION outlist {$$=cons(INTERSECTION,$1,$3);}
- | outitem {$$=cons(INTERSECTION,$1,0);}
- ;
-
-/* Now the gnarly part -- expression syntax */
-
-/* Support array dimension assignment */
-byexpr : expr BY byexpr {$$ = cons(BY, $1, $3);}
- | expr {$$ = cons(BY, $1, 0);}
- ;
-
-/* Support array subscripts (as lvalues) */
-subscr : subscr1 {$$ = $1;}
- | array SUB sublist {$$ = cons(SUB, $1, $3);}
- ;
-subscr1 : array SUB sublist1 {$$ = cons(SUB, $1, $3);}
- ;
-sublist : unambig sublist {$$ = cons(INTERSECTION, $1, $2);}
- | unambig sublist1 {$$ = cons(INTERSECTION, $1, $2);}
- ;
-sublist1: subscr1 {$$ = cons(INTERSECTION, $1, 0);}
- | osubscr1 {$$ = cons(INTERSECTION, $1, 0);}
- | unambig %prec HIGHPREC {$$ = cons(INTERSECTION, $1, 0);}
- ;
-
-/* Unary operators with arrays act like arrays only in expressions */
-osubscr : osubscr1 {$$ = $1;}
- | oparray SUB sublist
- {$$ = $1; $$->rval = cons(SUB, $$->rval, $3);}
- ;
-osubscr1: oparray SUB sublist1
- {$$ = $1; $$->rval = cons(SUB, $$->rval, $3);}
- ;
-
-/* here goes the general expression syntax */
-expr : unambig {$$ = $1;}
- | unambig SELECT unambig {$$ = cons(SELECT, $1, $3);}
- | unambig SELECT subscr {$$ = cons(SELECT, $1, $3);}
- | unambig SELECT osubscr {$$ = cons(SELECT, $1, $3);}
- | unambig MINGLE unambig {$$ = cons(MINGLE, $1, $3);}
- | unambig MINGLE subscr {$$ = cons(MINGLE, $1, $3);}
- | unambig MINGLE osubscr {$$ = cons(MINGLE, $1, $3);}
- | subscr {$$ = $1;}
- | osubscr {$$ = $1;}
- ;
-
-preftype: MESH {$$=MESH; } | ONESPOT {$$=ONESPOT;} | TWOSPOT {$$=TWOSPOT;};
-
-unambig : variable {$$ = $1;}
- | constant {$$ = $1;}
-
- /* deal with the bizarre unary-op syntax */
- | preftype UNARY NUMBER
- {
- $$ = newnode();
- $$->opcode = $2;
- $$->rval = newnode();
- $$->rval->opcode = $1;
- if($1 == MESH) {
- /* enforce the 16-bit constant constraint */
- if ((unsigned int)$3 > Max_small)
- lose(E017, yylineno, (char *)NULL);
- $$->rval->constant = $3;
- }
- else {
- $$->rval->constant = intern($1, $3);
- }
- }
-
- /* Now deal with the screwy unary-op interaction with grouping */
- | SPARK UNARY expr SPARK
- {
- $$ = newnode();
- $$->opcode = $2;
- $$->rval = $3;
- }
- | EARS UNARY expr EARS
- {
- $$ = newnode();
- $$->opcode = $2;
- $$->rval = $3;
- }
-
- | SPARK expr SPARK {$$ = $2;}
- | EARS expr EARS {$$ = $2;}
- ;
-
-%%
-
-static tuple *splat(void)
-/* try to recover from an invalid statement. */
-{
- tuple *sp;
- int tok, i;
- extern bool re_send_token;
-
- /*
- * The idea
- * here is to skip to the next DO, PLEASE or label, then unget that token.
- * which we can do with a tricky flag on the lexer (re_send_token).
- */
-
- /* fprintf(stderr,"attempting to splat at line %d....\n",yylineno); */
- for(i = 0,re_send_token = FALSE;;i++) {
- tok = lexer();
- if (!tok)
- {
- re_send_token = TRUE;
- tok = ' '; /* scanner must not see a NUL */
- break;
- }
- else if (tok == DO || tok == PLEASE || tok == LABEL) {
- re_send_token = TRUE;
- break;
- }
- }
- /*
- fprintf(stderr,"found %d on line %d after %d other tokens.\n",
- tok,yylineno,i);
- */
-
- /* generate a placeholder tuple for the text line */
- TARGET(sp, SPLATTERED, 0);
-
- return(sp);
-}
-
-/* ick.y ends here */
+++ /dev/null
-%{
-/*
- * NAME
- * lexer.l -- source for the C-INTERCAL lexical analyzer.
- *
-LICENSE TERMS
- Copyright (C) 1996 Eric S. Raymond
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-*/
-#include <stdio.h>
-#include <stdlib.h>
-#include <ctype.h>
-#include <string.h>
-#include <memory.h>
-#include "ick.h"
-#include "y.tab.h"
-#include "lose.h"
-
-#define YY_NO_UNPUT
-
-#ifndef yywrap
-static int yywrap(void)
-{
- return 1;
-}
-#endif /* yywrap */
-
-#ifdef YYLINENO_BY_HAND
-int yylineno = 1;
-#endif /* YYLINENO_BY_HAND */
-
-#ifdef MAIN
-YYSTYPE yylval;
-#endif /* MAIN */
-
-char **textlines = NULL;
-int textlinecount = 0;
-int politesse = 0;
-int stbeginline = 0;
-
-#ifdef FLEX_SCANNER
-static char linebuf[YY_BUF_SIZE];
-#else /* FLEX_SCANNER */
-static char linebuf[YYLMAX];
-#endif /* FLEX_SCANNER */
-
-static char *lineptr = linebuf;
-
-bool re_send_token = FALSE;
-
-int lexer(void);
-static int myatoi(char *text);
-
-#define SETLINENO \
- {if (stbeginline == 0) stbeginline = yylineno; \
- else if (stbeginline < 0) stbeginline = 0;}
-
-/*
- * The spectacular ugliness of INTERCAL syntax requires that the lexical
- * analyzer have two levels. One, embedded in the getc() function, handles
- * logical-line continuation and the ! abbrev, and stashes each logical
- * line away in a buffer accessible to the code generator (this is necessary
- * for the * construct to be interpreted correctly). The upper level is
- * generated by lex(1) and does normal tokenizing.
- */
-
-#undef getc
-int getc(FILE *fp)
-{
- extern FILE* yyin;
-
- static bool bangflag = FALSE;
- static bool backflag = FALSE;
-
- if (bangflag)
- {
- bangflag = FALSE;
- /* *lineptr++ = '!'; */
- return('.');
- }
- else if (backflag) /* converting ctrl-H (backspace) to two chars "^H" */
- {
- backflag = FALSE;
- /* *lineptr++ = '\b'; */
- return('H');
- }
- else
- {
- int c = fgetc(fp);
-
- if (feof(yyin))
- {
- *lineptr = '\0';
- return(EOF);
- }
-#ifdef BACKSLASH_CONTINUATION
- else if (c == '\\')
- {
- do {
- c = fgetc(fp);
-#ifdef YYLINENO_BY_HAND
- if( c == '\n' ) yylineno++;
-#endif /* YYLINENO_BY_HAND */
- } while
- (c != '\\' && isspace(c));
- }
-#endif /* BACKSLASH_CONTINUATION */
- if (c == '!')
- {
- *lineptr++ = '!';
- bangflag = TRUE;
- return(c = '\'');
- }
- else if (c == '\b') /* convert ctrl-H (backspace) to
- two chars "^" and "H" so lex can take it */
- {
- *lineptr++ = '\b';
- backflag = TRUE;
- return(c = '^');
- }
- else if (c == '\n')
- {
- *lineptr = '\0';
- lineptr = linebuf;
- if (yylineno >= textlinecount)
- {
- textlinecount += ALLOC_CHUNK;
- if (textlines)
- textlines = realloc(textlines,
- textlinecount * sizeof(char*));
- else
- textlines = malloc(textlinecount * sizeof(char*));
- if (!textlines)
- lose(E666, yylineno, (char *)NULL);
- }
- textlines[yylineno] = malloc(1 + strlen(linebuf));
- if (!textlines[yylineno])
- lose(E666, yylineno, (char *)NULL);
- strcpy(textlines[yylineno], linebuf);
-#ifdef YYLINENO_BY_HAND
- yylineno++;
-#endif /* YYLINENO_BY_HAND */
- return('\n');
- }
- else
- {
-#ifdef ACCEPT_LOWERCASE
- if (islower(c))
- c = toupper(c);
-#endif /* ACCEPT_LOWERCASE */
- return(*lineptr++ = c);
- }
- }
-}
-
-/* replace YY_INPUT so that it uses our getc function. */
-#undef YY_INPUT
-#define YY_INPUT(buf,result,max_size) \
- { \
- int c = getc(yyin); \
- if (c == EOF) { \
- if (ferror(yyin)) \
- YY_FATAL_ERROR("input in flex scanner failed"); \
- result = YY_NULL; \
- } else { \
- buf[0] = c; \
- result = 1; \
- } \
- }
-
-%}
-
-W [\ \t\n]*
-D [0-9][\ \t\n0-9]*
-
-%%
-
-{D} {yylval.numval = myatoi(yytext); return(NUMBER);}
-\. {return(ONESPOT);}
-\: {return(TWOSPOT);}
-\, {return(TAIL);}
-\; {return(HYBRID);}
-\# {return(MESH);}
-
-\$ |
-\xA2 |
-\xA3 |
-\xA4 |
-\xC2\xA2 |
-\xC2\xA3 |
-\xC2\xA4 |
-\xE2\x82\xA0 |
-\xE2\x82\xA1 |
-\xE2\x82\xA2 |
-\xE2\x82\xA3 |
-\xE2\x82\xA4 |
-\xE2\x82\xA5 |
-\xE2\x82\xA6 |
-\xE2\x82\xA7 |
-\xE2\x82\xA8 |
-\xE2\x82\xA9 |
-\xE2\x82\xAA |
-\xE2\x82\xAB |
-\xE2\x82\xAC |
-\xE0\xA7\xB2 |
-\xE0\xA7\xB3 |
-\xE0\xB8\xBF {return(MINGLE);}
-
-\~ {return(SELECT);}
-
-\& {yylval.numval = AND; return(UNARY);}
-V {yylval.numval = OR; return(UNARY);}
-"V^H-" |
-\xE2\x88\x80 |
-\? {yylval.numval = XOR; return(UNARY);}
-\^ {yylval.numval = FIN; return(UNARY);}
-@ {yylval.numval = WHIRL; return(UNARY);}
-[2-5]{W}@ {yylval.numval = WHIRL + myatoi(yytext) - 1; return(UNARY);}
-
-\' {return(SPARK);}
-\" {return(EARS);}
-
-\({W}{D}\) {SETLINENO; yylval.numval = myatoi(yytext); return(LABEL);}
-
-DO {SETLINENO; return(DO);}
-FAC {SETLINENO; return(DO);}
-PLEASE {SETLINENO; politesse++; return(DO);}
-PLACET {SETLINENO; politesse++; return(DO);}
-PLEASE{W}DO {SETLINENO; politesse++; return(DO);}
-PLACET{W}FACERE {SETLINENO; politesse++; return(DO);}
-NOT {return(NOT);}
-N\'T {return(NOT);}
-NON {return(NOT);}
-
-\%{W}{D} {yylval.numval = myatoi(yytext);
- if (yylval.numval && yylval.numval < 100)
- return(OHOHSEVEN);
- else
- lose(E017, yylineno, (char *)NULL);}
-SUB {return(SUB);}
-MULTIPLICATUS{W}A |
-BY {return(BY);}
-
-\<- {return(GETS);}
-CALCULANDUM |
-CALCULATING {yylval.numval = GETS; return(GERUND);}
-
-DEINDE |
-NEXT {stbeginline = 0; return(NEXT);}
-PROXIMANDUM |
-NEXTING {yylval.numval = NEXT; return(GERUND);}
-ALIENERE |
-FORGET {return(FORGET);}
-ALIENENDUM |
-FORGETTING {yylval.numval = FORGET; return(GERUND);}
-RECOLERE |
-RESUME {return(RESUME);}
-RECOLERENDUM |
-RESUMING {yylval.numval = RESUME; return(GERUND);}
-EXUERE |
-STASH {return(STASH);}
-EXUENDUM |
-STASHING {yylval.numval = STASH; return(GERUND);}
-INUERE |
-RETRIEVE {return(RETRIEVE);}
-INUENDUM |
-RETRIEVING {yylval.numval = RETRIEVE; return(GERUND);}
-DISSIMULARE |
-IGNORE {return(IGNORE);}
-DISSIMULANDUM |
-IGNORING {yylval.numval = IGNORE; return(GERUND);}
-MEMINISSE |
-REMEMBER {return(REMEMBER);}
-MEMINISSENDUM |
-REMEMBERING {yylval.numval = REMEMBER; return(GERUND);}
-ABSTINERE{W}A |
-ABSTAIN{W}FROM {return(ABSTAIN);}
-ABSTINENDUM |
-ABSTAINING {yylval.numval = ABSTAIN; return(GERUND);}
-REINSTARE |
-REINSTATE {return(REINSTATE);}
-REINSTATANDUM |
-REINSTATING {yylval.numval = REINSTATE; return(GERUND);}
-LEGERE{W}EX |
-READ{W}OUT {return(READ_OUT);}
-LEGENDUM |
-READING{W}OUT {yylval.numval = READ_OUT; return(GERUND);}
-SCRIBERE{W}IN |
-WRITE{W}IN {return(WRITE_IN);}
-SCRIBENDUM |
-WRITING{W}IN {yylval.numval = WRITE_IN; return(GERUND);}
-ADVENIRE{W}DE |
-COME{W}FROM {stbeginline = -stbeginline; return(COME_FROM);}
-ADVENENDUM |
-COMING{W}FROM {yylval.numval = COME_FROM; return(GERUND);}
-CONCEDERE |
-DESPERARE |
-GIVE{W}UP {return(GIVE_UP);}
-
-\+ {return(INTERSECTION);}
-
-{W} ;
-. {yylval.numval = yytext[0]; return(BADCHAR);}
-
-
-%%
-
-int lexer(void)
-{
- static int tok = BADCHAR;
-
- if (re_send_token)
- re_send_token = FALSE;
- else
- {
- tok = yylex();
-#ifdef YYDEBUG
- if (yydebug)
- (void) fprintf(stdout, "yylex: returning token %d\n", tok);
-#endif /* YYDEBUG */
- }
-
-#ifdef YYDEBUG
- if (yydebug)
- (void) fprintf(stdout, "lexer: returning token %d\n", tok);
-#endif /* YYDEBUG */
- return(tok);
-}
-
-static int myatoi(char *text)
-{
-#define MAXTEXT 100
- static char buf[MAXTEXT];
- register int i;
-
- for(buf[i = 0] = '\0';*text && i < MAXTEXT;text++) {
- if(isdigit(*text)) {
- buf[i++] = *text;
- }
- }
- buf[i] = '\0';
- return atoi(buf);
-}
-
-void yyerror(char *errtype)
-{
-#ifdef MAIN
- (void) printf("lextest: lexer error: %s.\n", errtype);
-#else /* MAIN */
- /* lose(E017, yylineno, (char *)NULL); */
- (void) errtype;
-#endif /* MAIN */
-}
-
-#ifdef MAIN
-int main(void)
-{
- int t;
-
- while ((t = yylex()) > 0)
- {
- (void) printf("%03d %09d\n", t, yylval.numval);
- yylval.numval = 0;
- }
- return 0;
-}
-#endif /* MAIN */
+++ /dev/null
-/*
- *
- * NAME
- * lose.c -- report INTERCAL compile- or run-time error
- *
-LICENSE TERMS
- Copyright (C) 1996 Eric S. Raymond
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- */
-/*LINTLIBRARY*/
-#include <stdio.h>
-#include <stdlib.h>
-#include "lose.h"
-
-void lose(char *m, int n, char *s)
-{
- (void) fprintf(stderr,
- "ICL%c%c%cI\t",
- m[0], m[1], m[2]);
- if (s)
- (void) fprintf(stderr, m + 4, s, n);
- else
- (void) fprintf(stderr, m + 4, n);
- (void) fprintf(stderr, " CORRECT SOURCE AND RESUBNIT\n");
- exit(atoi(m));
-}
-
-/* lose.c ends here */
-
-
+++ /dev/null
-/* lose.h --- error message strings */
-
-/*
- * Note: these error message texts, with one exception, are direct from
- * the Princeton compiler (INTERCAL-72) sources (transmitted by Don Woods).
- * The one exception is E632, which in INTERCAL-72 had the error message
- * PROGRAM ATTEMPTED TO EXIT WITHOUT ERROR MESSAGE
- * ESR's "THE NEXT STACK HAS RUPTURED!..." has been retained on the grounds
- * that it is more obscure and much funnier. For context, find a copy of
- * Joe Haldeman's SF short story "A !Tangled Web", first published in
- * Analog magazine sometime in 1983 and later anthologized in the author's
- * "Infinite Dreams" (Ace 1985).
- */
-/* An undecodable statement has been encountered in the course of execution. */
-#define E000 "000 %s\n\
- ON THE WAY TO %d\n"
-/* An expression contains a syntax error. */
-#define E017 "017 DO YOU EXPECT ME TO FIGURE THIS OUT?\n\
- ON THE WAY TO %d\n"
-/* Improper use has been made of statement identifiers. */
-#define E079 "079 PROGRAMMER IS INSUFFICIENTLY POLITE\n\
- ON THE WAY TO %d\n"
-/* Improper use has been made of statement identifiers. */
-#define E099 "099 PROGRAMMER IS OVERLY POLITE\n\
- ON THE WAY TO %d\n"
-/* Program has attempted 80 levels of NEXTing */
-#define E123 "123 PROGRAM HAS DISAPPEARED INTO THE BLACK LAGOON\n\
- ON THE WAY TO %d\n"
-/* Program has attempted to transfer to a non-existent line label */
-#define E129 "129 PROGRAM HAS GOTTEN LOST\n\
- ON THE WAY TO WHO KNOWS WHERE\n"
-/* An ABSTAIN or REINSTATE statement references a non-existent line label */
-#define E139 "139 I WASN'T PLANNING TO GO THERE ANYWAY\n\
- ON THE WAY TO %d\n"
-/* A line label has been multiply defined. */
-#define E182 "182 YOU MUST LIKE THIS LABEL A LOT!\n\
- ON THE WAY TO %d\n"
-/* An invalid line label has been encountered. */
-#define E197 "197 SO! 65535 LABELS AREN'T ENOUGH FOR YOU?\n\
- ON THE WAY TO %d\n"
-/* An expression involves an unidentified variable. */
-#define E200 "200 NOTHING VENTURED, NOTHING GAINED\n\
- ON THE WAY TO %d\n"
-/* An attempt has been made to give an array a dimension of zero. */
-#define E240 "240 ERROR HANDLER PRINTED SNIDE REMARK\n\
- ON THE WAY TO %d\n"
-/* Invalid dimensioning information was supplied
- * in defining or using an array. */
-#define E241 "241 VARIABLES MAY NOT BE STORED IN WEST HYPERSPACE\n\
- ON THE WAY TO %d\n"
-/* A 32-bit value has been assigned to a 16-bit variable. */
-#define E275 "275 DON'T BYTE OFF MORE THAN YOU CAN CHEW\n\
- ON THE WAY TO %d\n"
-/* A retrieval has been attempted for an unSTASHed value. */
-#define E436 "436 THROW STICK BEFORE RETRIEVING!\n\
- ON THE WAY TO %d\n"
-/* A WRITE IN statement or interleave ($) operation
- * has produced value requiring over 32 bits to represent. */
-#define E533 "533 YOU WANT MAYBE WE SHOULD IMPLEMENT 64-BIT VARIABLES?\n\
- ON THE WAY TO %d\n"
-/* Insufficient data. (raised by reading past EOF) */
-#define E562 "562 I DO NOT COMPUTE\n\
- ON THE WAY TO %d\n"
-/* Input data is invalid. */
-#define E579 "579 WHAT BASE AND/OR LANGUAGE INCLUDES %s?\n\
- ON THE WAY TO %d\n"
-/* The expression of a RESUME statement evaluated to #0. */
-#define E621 "621 ERROR TYPE 621 ENCOUNTERED\n\
- ON THE WAY TO %d\n"
-/* Program execution terminated via a RESUME statement instead of GIVE UP. */
-#define E632 "632 THE NEXT STACK RUPTURES. ALL DIE. OH, THE EMBARRASSMENT!\n\
- ON THE WAY TO %d\n"
-/* Execution has passed beyond the last statement of the program. */
-#define E633 "633 PROGRAM FELL OFF THE EDGE\n\
- ON THE WAY TO THE NEW WORLD\n"
-/* A compiler error has occurred (see section 8.1). */
-#define E774 "774 RANDOM COMPILER BUG\n\
- ON THE WAY TO %d\n"
-/* An unexplainable compiler error has occurred (see J. Lyon or D. Woods). */
-#define E778 "778 UNEXPLAINED COMPILER BUG\n\
- ON THE WAY TO %d\n"
-
-/*
- * These errors are unique to C-INTERCAL.
- */
-/* You tried to use a C-INTERCAL extension with the `traditional' flag on */
-#define E111 "111 COMMUNIST PLOT DETECTED, COMPILER IS SUICIDING\n\
- ON THE WAY TO %d\n"
-/* Cannot find the magically included system library */
-#define E127 "127 SAYING 'ABRACADABRA' WITHOUT A MAGIC WAND WON'T DO YOU ANY GOOD\n\
- ON THE WAY TO THE CLOSET\n"
-/* Out of stash space */
-#define E222 "222 BUMMER, DUDE!\n\
- ON THE WAY TO %d\n"
-/* Too many variables. */
-#define E333 "333 YOU CAN'T HAVE EVERYTHING, WHERE WOULD YOU PUT IT?\n\
- ON THE WAY TO %d\n"
-/* A COME FROM statement references a non-existent line label. */
-#define E444 "444 IT CAME FROM BEYOND SPACE\n\
- ON THE WAY TO %d\n"
-/* More than one COME FROM references the same label. */
-#define E555 "555 FLOW DIAGRAM IS EXCESSIVELY CONNECTED\n\
- ON THE WAY TO %d\n"
-/* Too many source lines. */
-#define E666 "666 COMPILER HAS INDIGESTION\n\
- ON THE WAY TO %d\n"
-/* No such source file. */
-#define E777 "777 A SOURCE IS A SOURCE, OF COURSE, OF COURSE\n\
- ON THE WAY TO %d\n"
-/* Can't open C output file */
-#define E888 "888 I HAVE NO FILE AND I MUST SCREAM\n\
- ON THE WAY TO %d\n"
-/* Can't open C skeleton file. */
-#define E999 "999 NO SKELETON IN MY CLOSET, WOE IS ME!\n\
- ON THE WAY TO %d\n"
-/* Source file name with invalid extension (use .i or .[3-7]i). */
-#define E998 "998 EXCUSE ME,\n\
- YOU MUST HAVE ME CONFUSED WITH SOME OTHER COMPILER\n"
-/* Illegal possession of a controlled unary operator. */
-#define E997 "997 ILLEGAL POSSESSION OF A CONTROLLED UNARY OPERATOR.\n\
- ON THE WAY TO %d\n"
-
-extern int lineno;
-
-extern void lose(char *m, int n, char *s);
-
-/* lose.h ends here */
+++ /dev/null
-/*
- * numeral.c -- internationalization support for INTERCAL input.
- *
- * After release 0.5, I wrote:
- *
- * 2. (ESR) Input format internationalization -- allow WRITE IN input digits in
- * major languages such as Nahuatl, Tagalog, Sanskrit, and Basque.
- *
- * The twisted loons in the alt.folklore.computers crowd loved this
- * idea, and I actually got sent digit lists for Nahuatl, Tagalog,
- * Sanskrit, and Basque -- also, Kwakiutl, Georgian, Ojibwe. Albanian,
- * and Volap\"uk. I've left out Albanian (didn't want to keep track
- * of the dipthong diacritical) and Ojibwe (no zero digit). So:
- * Nahuatl, Tagalog, Sanskrit, Basque, Georgian, Kwakiutl, and
- * Volap\"uk are now supported in addition to English.
- *
- * As of release 0.18, Volap\"uk digits can be entered in either traditional
- * Tex format, Latin-1, or UTF-8. Latin is also now a supported language,
- * to fulfill the requirement for Ancient Roman localization.
- *
-LICENSE TERMS
- Copyright (C) 1996 Eric S. Raymond
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
- */
-
-typedef struct
-{
- char *name;
- int value;
-}
-numeral;
-
-static numeral numerals[] =
-{
-/* English */
- { "OH", 0 },
- { "ZERO", 0 },
- { "ONE", 1 },
- { "TWO", 2 },
- { "THREE", 3 },
- { "FOUR", 4 },
- { "FIVE", 5 },
- { "SIX", 6 },
- { "SEVEN", 7 },
- { "EIGHT", 8 },
- { "NINE", 9 },
- { "NINER", 9 }, /* For all you junior birdmen */
-/* Sanskrit */
- { "SUTYA", 0 }, /* Retroflex s, pronounced halfway to sh */
- { "SHUTYA", 0 },
- { "EKA", 1 },
- { "DVI", 2 },
- { "TRI", 3 },
- { "CHATUR", 4 },
- { "PANCHAN", 5 },
- { "SHASH", 6 },
- { "SAPTAM", 7 },
- { "ASHTAN", 8 },
- { "NAVAN", 9 },
-/* Basque */
- { "ZEROA", 0 },
- { "BAT", 1 },
- { "BI", 2 },
- { "HIRO", 3 },
- { "LAU", 4 },
- { "BORTZ", 5 },
- { "SEI", 6 },
- { "ZAZPI", 7 },
- { "ZORTZI", 8 },
- { "BEDERATZI", 9 },
-/* Tagalog */
- { "WALA", 0 },
- { "ISA", 1 },
- { "DALAWA", 2 },
- { "TATLO", 3 },
- { "APAT", 4 },
- { "LIMA", 5 },
- { "ANIM", 6 },
- { "PITO", 7 },
- { "WALO", 8 },
- { "SIYAM", 9 },
-/* Classical Nahuatl */
- { "AHTLE", 0 }, /* Actually `nothing'; no separate zero word is known */
- { "CE", 1 },
- { "OME", 2 },
- { "IEI", 3 },
- { "NAUI", 4 },
- { "NACUILI", 5 },
- { "CHIQUACE", 6 },
- { "CHICOME", 7 },
- { "CHICUE", 8 },
- { "CHICUNAUI", 9 },
-/* Georgian */
- { "NULI", 0 },
- { "ERTI", 1 },
- { "ORI", 2 },
- { "SAMI", 3 },
- { "OTXI", 4 },
- { "XUTI", 5 },
- { "EKSVI", 6 },
- { "SHVIDI", 7 },
- { "RVA", 8 },
- { "CXRA", 9 },
-/* Kwakiutl (technically, Kwak'wala) */
- { "KE'YOS", 0 }, /* Actually `nothing'; no separate zero word is known */
- { "'NEM", 1 },
- { "MAL'H", 2 },
- { "YUDEXW", 3 },
- { "MU", 4 },
- { "SEK'A", 5 },
- { "Q'ETL'A", 6 },
- { "ETLEBU", 7 },
- { "MALHGWENALH", 8 },
- { "'NA'NE'MA", 9 },
-/* Volap\"uk */
- { "NOS", 0 },
- { "BAL", 1 },
- { "TEL", 2 },
- { "KIL", 3 },
- { "FOL", 4 },
- { "LUL", 5 },
- { "M\\\"AL", 6 },
- { "M\xC4L", 6 }, /* Latin-1 support */
- { "M\xA3\xA4L", 6 }, /* UTF-8 support */
- { "VEL", 7 },
- { "J\\\"OL", 8 },
- { "J\xD6L", 8 }, /* Latin-1 support */
- { "J\xA3\x96L", 8 }, /* UTF-8 support */
- { "Z\\\"UL", 9 },
- { "Z\xDCL", 9 }, /* Latin-1 support */
- { "Z\xA3\x9CL", 9 }, /* UTF-8 support */
-/* Latin localization */
- { "NIL", 0 },
- { "NIHIL", 0 },
- { "UNUS", 1 },
- { "UNA", 1 },
- { "UNUM", 1 },
- { "DUO", 2 },
- { "DUAE", 2 },
- { "TRES", 3 },
- { "QUATTUOR", 4 },
- { "QUATUOR", 4 },
- { "QUINQUE", 5 },
- { "SEX", 6 },
- { "SEPTEM", 7 },
- { "OCTO", 8 },
- { "NOVEM", 9 },
-};
-
-/* numeral.c ends here */
+++ /dev/null
-/****************************************************************************
-
-NAME
- perpetrate.c -- main routine for C-INTERCAL compiler.
-
-DESCRIPTION
- This is where all the dirty work begins and ends.
-
-LICENSE TERMS
- Copyright (C) 1996 Eric S. Raymond
-
- This program is free software; you can redistribute it and/or modify
- it under the terms of the GNU General Public License as published by
- the Free Software Foundation; either version 2 of the License, or
- (at your option) any later version.
-
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- GNU General Public License for more details.
-
- You should have received a copy of the GNU General Public License
- along with this program; if not, write to the Free Software
- Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-
-****************************************************************************/
-/*LINTLIBRARY */
-#include <stdio.h>
-#include <stdlib.h>
-#include <unistd.h>
-#include <string.h>
-#include <signal.h>
-#include <time.h>
-#include "ick.h"
-#include "feh.h"
-#include "y.tab.h"
-#include "sizes.h"
-#include "lose.h"
-
-#ifndef ICKINCLUDEDIR
-#define ICKINCLUDEDIR "/usr/local/include"
-#endif
-#ifndef ICKLIBDIR
-#define ICKLIBDIR "/usr/local/share"
-#endif
-#ifndef CC
-#define CC "gcc"
-#endif
-
-#ifdef USE_YYRESTART
-/* function supplied by lex */
-extern void yyrestart(FILE*);
-#endif /* USE_YYRESTART */
-
-/* function created by yacc */
-extern int yyparse(void);
-
-int yydebug;
-
-/* compilation options */
-bool compile_only; /* just compile into C, don't run the linker */
-bool traditional; /* insist on strict INTERCAL-72 conformance */
-bool nocompilerbug; /* disable error E774 */
-
-static bool dooptimize; /* do optimizations? (controlled by -O) */
-static bool clockface; /* set up output to do IIII for IV */
-
-#define SKELETON "ick-wrap.c"
-#define SYSLIB "pit/lib/syslib"
-
-/* numeric base defaults, exported to other files */
-
-#define DEFAULT_BASE 2
-#define DEFAULT_SMALL_DIGITS 16
-#define DEFAULT_LARGE_DIGITS 32
-#define DEFAULT_MAX_SMALL 0xffffL
-#define DEFAULT_MAX_LARGE 0xffffffffL
-
-int Base;
-int Small_digits;
-int Large_digits;
-unsigned int Max_small;
-unsigned int Max_large;
-
-int lineno; /* after yyparse, this is the total number of statements */
-
-/* currently supported numeric bases, not exported */
-static int maxbase = 7;
-static int smallsizes[8] = {0, 0, 16, 10, 8, 6, 6, 5};
-static unsigned int maxsmalls[8] =
- {0, 0, 65535, 59048, 65535, 15624, 46655, 16806};
-
-static char *compiler;
-
-atom *oblist = NULL, *obdex;
-int obcount = 0;
-int nonespots, ntwospots, ntails, nhybrids;
-
-tuple *tuples = NULL;
-int tuplecount = 0;
-
-static void abend(int signim)
-{
- lose(E778, yylineno, (char *)NULL);
- (void) signim;
-}
-
-static void print_usage(char *prog, char *options)
-{
- fprintf(stderr,"Usage: %s [-%s] <file> [<file> ... ]\n",prog,options);
- fprintf(stderr,"\t-b\t:reduce the probability of E774 to zero\n");
- fprintf(stderr,"\t-c\t:compile INTERCAL to C, but don't compile C\n");
- fprintf(stderr,"\t-d\t:print debugging information (implies -c)\n");
- fprintf(stderr,"\t-t\t:traditional mode, accept only INTERCAL-72\n");
- fprintf(stderr,"\t-C\t:clockface output (e.g. use IIII instead of IV)\n");
- fprintf(stderr,"\t-O\t:attempt to optimize generated code\n");
- fprintf(stderr,"\t<file>\tINTERCAL source file(s) (use extension .i)\n");
- fprintf(stderr,"\t\teach file produces a separate output program.\n");
-}
-
-int main(int argc, char *argv[])
-{
- extern int optind; /* set by getopt */
- char buf[BUFSIZ], buf2[BUFSIZ], *chp, *strrchr();
- tuple *tp;
- atom *op;
- int c, i;
- char *includedir, *libdir, *getenv();
- FILE *ifp, *ofp;
- int maxabstain, nextcount, bugline;
- bool needsyslib, firstfile;
-
- if (!(includedir = getenv("ICKINCLUDEDIR")))
- includedir = ICKINCLUDEDIR;
- if (!(libdir = getenv("ICKLIBDIR")))
- libdir = ICKLIBDIR;
- if (!(compiler = getenv("CC")))
- compiler = CC;
-
- while ((c = getopt(argc, argv, "bcdtOC@")) != EOF)
- {
- switch (c)
- {
- case 'b':
- nocompilerbug = TRUE;
- break;
-
- case 'c':
- compile_only = TRUE;
- break;
-
- case 'd':
- yydebug = compile_only = TRUE;
- break;
-
- case 'C':
- clockface = TRUE;
- break;
-
- case 't':
- traditional = TRUE;
- break;
-
- case 'O':
- dooptimize = TRUE;
- break;
-
- case '?':
- default:
- case '@':
- print_usage(argv[0],"bcdtCO");
- exit(1);
- break;
- }
- }
-
- (void) signal(SIGSEGV, abend);
-#ifdef SIGBUS
- (void) signal(SIGBUS, abend);
-#endif /* SIGBUS */
-
- if (!nocompilerbug) {
-#ifdef USG
- srand48(time(NULL) + getpid());
-#else
- srand(time(NULL));
-#endif /* UNIX */
- }
-
- (void) sprintf(buf2,"%s/%s",libdir,SKELETON);
-
- /* now substitute in tokens in the skeleton */
- if ((ifp = fopen(buf2, "r")) == (FILE *)NULL)
- lose(E999, 1, (char *)NULL);
- buf[strlen(buf) - 2] = '\0';
-
- for (firstfile = TRUE; optind < argc; optind++, firstfile = FALSE)
- {
- if (freopen(argv[optind], "r", stdin) == (FILE *)NULL)
- lose(E777, 1, (char *)NULL);
- else
- {
- /* strip off the file extension */
- if(!(chp = strrchr(argv[optind],'.')))
- {
- lose(E998, 1, (char *)NULL);
- }
- *chp++ = '\0';
-
- /* wwp: reset the base variables to defaults, because if the */
- /* sourcefile has extension .i they will not be reset in the */
- /* following chunk of code. but i don't want to modify the */
- /* following chunk of code because i think it is very clever; */
- /* grabs the base on the first pass, then validates the rest */
- /* of the extension on the second. */
- Base = DEFAULT_BASE;
- Small_digits = DEFAULT_SMALL_DIGITS;
- Large_digits = DEFAULT_LARGE_DIGITS;
- Max_small = DEFAULT_MAX_SMALL;
- Max_large = DEFAULT_MAX_LARGE;
-
- /* determine the file type from the extension */
- while (strcmp(chp,"i"))
- {
- Base = strtol(chp,&chp,10);
- if (Base < 2 || Base > maxbase)
- lose(E998, 1, (char *)NULL);
- else if (traditional && Base != 2)
- lose(E111, 1, (char *)NULL);
- Small_digits = smallsizes[Base];
- Large_digits = 2 * Small_digits;
- Max_small = maxsmalls[Base];
- if (Max_small == 0xffff)
- Max_large = 0xffffffff;
- else
- Max_large = (Max_small + 1) * (Max_small + 1) - 1;
- }
-
- /* zero out tuple and oblist storage */
- treset();
- politesse = 0;
-
- /* reset the lex/yacc environment */
- if (!firstfile)
- {
-#ifdef NEED_YYRESTART
- yyrestart(stdin);
-#endif /* NEED_YYRESTART */
-#ifdef YYLINENO_BY_HAND
- yylineno = 1;
-#endif /* YYLINENO_BY_HAND */
- }
-
- /* compile tuples from current input source */
- yyparse();
-
- /*
- * Miss Manners lives.
- */
- if (lineno > 2)
- {
- if (politesse == 0 || (lineno - 1) / politesse >= 5)
- lose(E079, yylineno, (char *)NULL);
- else if (lineno / politesse < 3)
- lose(E099, yylineno, (char *)NULL);
- }
-
- /*
- * check if we need to magically include the system library
- */
- needsyslib = FALSE;
- for (tp = tuples; tp->type; tp++) {
- /*
- * If some label in the (1000)-(2000) range is defined,
- * then clearly the syslib is already there, so we
- * can stop searching and won't need the syslib.
- */
- if (tp->label >= 1000 && tp->label <= 1999) {
- needsyslib = FALSE;
- break;
- }
- /*
- * If some label in the (1000)-(2000) range is being
- * called, we might need the system library.
- */
- if (tp->type == NEXT && tp->u.target >= 1000 &&
- tp->u.target <= 1999)
- needsyslib = TRUE;
- }
- if ( needsyslib ) {
- if (Base == 2)
- (void) sprintf(buf2, "%s/%s.i", libdir, SYSLIB);
- else
- (void) sprintf(buf2, "%s/%s.%di", libdir, SYSLIB, Base);
- if ( freopen(buf2, "r", stdin) == (FILE*) NULL ) {
- lose(E127, 1, (char*) NULL);
- }
-#ifdef USE_YYRESTART
- yyrestart(stdin);
-#endif /* USE_YYRESTART */
- yyparse();
- }
-
- /*
- * Now propagate type information up the expression tree.
- * We need to do this because the unary-logical operations
- * are sensitive to the type widths of their operands, so
- * we have to generate different code depending on the
- * deducible type of the operand.
- */
- for (tp = tuples; tp->type; tp++)
- if (tp->type == GETS || tp->type == RESIZE
- || tp->type == FORGET || tp->type == RESUME)
- typecast(tp->u.node);
-
- codecheck(); /* check for compile-time errors */
-
- /* perform optimizations */
- if (dooptimize)
- for (tp = tuples; tp->type; tp++)
- if (tp->type == GETS || tp->type == RESIZE
- || tp->type == FORGET || tp->type == RESUME)
- optimize(tp->u.node);
-
- /* decide if and where to place the compiler bug */
-#ifdef USG
- if (!nocompilerbug && lrand48() % 10 == 0)
- bugline = (int)(lrand48() % lineno);
-#else
- if (!nocompilerbug && rand() % 10 == 0)
- bugline = rand() % lineno;
-#endif
- else
- bugline = -1;
-
- /* set up the generated C output file name */
- (void) strcpy(buf, argv[optind]);
- (void) strcat(buf, ".c");
- if ((ofp = fopen(buf, "w")) == (FILE *)NULL)
- lose(E888, 1, (char *)NULL);
-
- fseek(ifp,0L,0); /* rewind skeleton file */
-
- while ((c = fgetc(ifp)) != EOF)
- if (c != '$')
- (void) fputc(c, ofp);
- else switch(fgetc(ifp))
- {
- case 'A': /* source name stem */
- (void) fputs(argv[optind], ofp);
- break;
-
- case 'B': /* # of statements */
- (void) fprintf(ofp, "%d", lineno);
- break;
-
- case 'C': /* initial abstentions */
- maxabstain = 0;
- for (tp = tuples; tp->type; tp++)
- if (tp->exechance <= 0 && tp - tuples + 1 > maxabstain)
- maxabstain = tp - tuples + 1;
- if (maxabstain)
- {
- (void) fprintf(ofp, " = {");
- for (tp = tuples; tp < tuples + maxabstain; tp++)
- if (tp->exechance > 0)
- (void) fprintf(ofp, "0, ");
- else {
- (void) fprintf(ofp, "1, ");
- tp->exechance = -tp->exechance;
- }
- (void) fprintf(ofp, "}");
- }
- break;
-
- case 'D': /* linetypes array for abstention handling */
- maxabstain = 0;
- for (tp = tuples; tp->type; tp++)
- if (tp->type == ENABLE || tp->type == DISABLE)
- maxabstain++;
- if (maxabstain)
- {
- (void) fprintf(ofp, "#define UNKNOWN\t\t0\n");
- i = 0;
- for (; i < (int)(sizeof(enablers)/sizeof(char *)); i++)
- (void) fprintf(ofp,
- "#define %s\t%d\n",
- enablers[i], i+1);
-
- (void) fprintf(ofp, "int linetype[] = {\n");
- for (tp = tuples; tp->type; tp++)
- if (tp->type >= GETS && tp->type <= COME_FROM)
- (void) fprintf(ofp,
- " %s,\n",
- enablers[tp->type - GETS]);
- else
- (void) fprintf(ofp, " UNKNOWN,\n");
- (void) fprintf(ofp, "};\n");
- }
- break;
-
- case 'E': /* extern to intern map */
- (void) fprintf(ofp,"int Base = %d;\n",Base);
- (void) fprintf(ofp,"int Small_digits = %d;\n",
- Small_digits);
- (void) fprintf(ofp,"int Large_digits = %d;\n",
- Large_digits);
- (void) fprintf(ofp,"unsigned int Max_small = 0x%x;\n",
- Max_small);
- (void) fprintf(ofp,"unsigned int Max_large = 0x%x;\n",
- Max_large);
- if (nonespots)
- {
- (void) fprintf(ofp,
- "static type16 onespots[%d];\n",
- nonespots);
- (void) fprintf(ofp,
- "static bool oneforget[%d];\n",
- nonespots);
- }
- if (ntwospots)
- {
- (void) fprintf(ofp,
- "static type32 twospots[%d];\n",
- ntwospots);
- (void) fprintf(ofp,
- "static bool twoforget[%d];\n",
- ntwospots);
- }
- if (ntails)
- {
- (void) fprintf(ofp,
- "static array tails[%d];\n",
- ntails);
- (void) fprintf(ofp,
- "static bool tailforget[%d];\n",
- ntails);
- }
- if (nhybrids)
- {
- (void) fprintf(ofp,
- "static array hybrids[%d];\n",
- nhybrids);
- (void) fprintf(ofp,
- "static bool hyforget[%d];\n",
- nhybrids);
- }
- if (yydebug || compile_only)
- for (op = oblist; op < obdex; op++)
- (void) fprintf(ofp, " /* %s %d -> %d */\n",
- nameof(op->type, vartypes),
- op->extindex,
- op->intindex);
- break;
-
- case 'F': /* set clockface option? */
- if (clockface)
- (void) fprintf(ofp, "clockface(TRUE);");
- break;
-
- case 'G': /* degenerated code */
- for (tp = tuples, i = 0; tp->type; tp++, i++)
- {
- emit(tp, ofp);
- if (i == bugline)
- (void) fprintf(ofp, " lose(E774, lineno, "
- "(char *)NULL);\n");
- }
- break;
-
- case 'H': /* dispatching for resumes */
- nextcount = 0;
- for (tp = tuples; tp->type; tp++)
- if (tp->type == NEXT)
- nextcount++;
- if (nextcount)
- {
- (void) fputs("/* generated switch for resumes */",ofp);
- (void) fputs("top:\n switch(skipto)\n {\n", ofp);
- for (tp = tuples; tp->type; tp++)
- if (tp->type == NEXT)
- (void) fprintf(ofp,
- "\tcase %d: goto N%d; break;\n",
- (int)(tp-tuples+1), (int)(tp-tuples+1));
- (void) fprintf(ofp, " }");
- }
- break;
-
- case 'J': /* # of source file lines */
- (void) fprintf(ofp, "%d", yylineno);
- break;
- }
-
- (void) fclose(ofp);
-
- /* OK, now sic the C compiler on the results */
- if (!compile_only)
- {
- (void) sprintf(buf2,
- "%s %s -I%s -L%s -lick -o %s",
- compiler, buf, includedir, libdir,
- argv[optind]);
- (void) system(buf2);
- (void) unlink(buf);
- }
- }
- }
- (void) fclose(ifp);
- return 0;
-}
-
-/* perpetrate.c ends here */
+++ /dev/null
-This is the directory of programs written in INTERCAL. Most of these
-are no doubt full of bugs. Don't complain, you're lucky if anything
-written in INTERCAL works at all.
-
-The subdirectory lib contains code fragments that are not complete
-programs.
-
-Contents:
-
-from original manual:
- sample.i Returns absolute value of a 16-bit 2s-complement number
- lib/syslib.i Standard library, with bugs fixed
- lib/syslib-orig.i Standard library (original buggy version)
-
-by Jon Blow <jon@sampo.com>
- sink.i Simple test program
- random.i Random number program
- lib/plus.i Increment .1
-
-by Hans Olsson <f88ho@efd.lth.se>
- lib/1910.doc Listing of a random number routine. Hans said he wrote this
- because he couldn't find (1910) in the system library, but
- it's there in our lib/syslib.i. We keep this around as an
- example. (What? Throw away INTERCAL code? Perish the thought!)
-
-by Louis Howell <nazgul@netcom.com>
- life.i Conway's game of Life, standard INTERCAL version
- life2.i This version uses COME FROM and character output
- blinkers
- t_tet
- glider
- gun Input files for both Life programs
- bubble.i Bubble sort
- icat.i Sends input to output
- lib/lib2.i New library routines: decrement, decrement and branch on 0,
- add bit, 16-bit division with remainder, exponentiation
- pi.i Calculate pi
- primes.i Find prime numbers
- pow.i Prints a list of nth powers using old exponentiation routine
- lib/syslib.i Corrected version of system library
- iching1.i Generates I Ching hexagrams
- iching2.i This version uses a lookup table to find the sequence number
- iching.doc Description of the two I Ching programs
- change.i Count up different ways to make change
- change.doc Description of change.i
-
-by Matt Dimeo <mdimeo@brooktree.com>
- beer.i Print out the lyrics to "99 Bottles of Beer On The Wall"
-
-by Stinglai Ka'abi <stinglai@bureau.World.GOV>:
- random2.i Another random-number generator
-
-by Jacob Mandelson <jlm@cco.caltech.edu>
- rot13.i Prints ROT-13 of its input
-
-by Jan-Pieter Cornet <johnpc@xs4all.nl>
- hail_mary.3i Print 1,000,000 Hail Marys
- count.3i Count from 1 to 10 in TriINTERCAL
- iogerunds.i Demonstrate gerund abstention
-
-by Clemens Meier <clmeier@lili.uni-bielefeld.de>
- rot13b.i Another ROT-13 program
-
-By Brian Raiter <breadbox@muppetlabs.com>
- lib/numio.i I/O routines
- lib/numio.doc Description of the I/O routines
- lib/syslib.3i
- lib/syslib.4i
- lib/syslib.5i
- lib/syslib.6i Translations of the standard library to
- lib/syslib.7i C-INTERCAL's other bases.
- lib/syslib3-7.doc Documentation for same
- hello.i The traditional hello world program
- ins.i Intersections & Splats, a Mastermind-style game
- ins.doc Documentation for I&S
- yapp.i Prints an INTERCAL program that prints
- yapp.doc Description of yapp.i
- quine.i Prints itself
- lib/floatlib.i Floating-point routines
- lib/floatlib.doc Documentation for the floating-point routines
- flonck.i An RPN calculator
- flonck.doc Documentation for flonck.i
- fft.i Fast Fourier Transform
- fft.doc Description of fft.i
- delta.fft
- tophat.fft Sample input for FFT
-
-The subdirectory tests contains some programs written only to test the
-compiler.
-
-by Donald Knuth
- knuth.i Demonstrates Don Knuth's patch for handling multiline comments
-
-by David Moews
- test1.i Prints DO THIS TEST HAS BEEN SUCCESSFULLY COMPLETED
- test2.i Reads in two numbers and multiplies their product
-
-David Moews wrote of the latter (test2.i):
-
-The following program reads in two numbers and then prints their product.
-It consists of a trivial calling program followed by a cleaned-up version
-of a portion of the INTERCAL subroutine library. (Only a portion of
-the INTERCAL subroutine library is present in the posted manual, and
-that portion is full of typos.)
-
-The programs test16bit.i, testarray.i, testcf.i, testlib2.i, mult.i,
-limits.{i,3i}, testops.{3i,5i}, testsplat.i, were all written by Louis
-Howell. Of these, testcf.i might be considered an interesting
-puzzle---try to figure out what it's doing. The others are pretty
-boring, but are included as diagnostics and because so few other
-example programs exist. Not all of these even produce interesting
-diagnostic output; it may be necessary to look at the degenerated C
-code to determine if the compiler is doing the right thing.
-
-
-End of file CATALOG
--------------------
+++ /dev/null
-/* sizes.h -- constants defining the numeric base for INTERCAL variations */
-
-extern int Base;
-extern int Small_digits;
-extern int Large_digits;
-extern unsigned int Max_small;
-extern unsigned int Max_large;
-
-/* sizes.h ends here */
projects / intercal.git / commitdiff