From: Eric S. Raymond Date: Tue, 4 Mar 2003 18:31:11 +0000 (-0500) Subject: Ready to ship 0.22. X-Git-Tag: 0.22 X-Git-Url: http://thyrsus.com/gitweb/?a=commitdiff_plain;h=c862aaeb52981b9c63800a6cfb5c9ceca2a41b81;p=intercal.git Ready to ship 0.22. --- diff --git a/Makefile b/Makefile deleted file mode 100644 index 8b66d46..0000000 --- a/Makefile +++ /dev/null @@ -1,114 +0,0 @@ -# -# 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 - diff --git a/Makefile.in b/Makefile.in new file mode 100644 index 0000000..640161f --- /dev/null +++ b/Makefile.in @@ -0,0 +1,115 @@ +# +# 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 + diff --git a/READ.ME b/READ.ME deleted file mode 100644 index a87c0f8..0000000 --- a/READ.ME +++ /dev/null @@ -1,128 +0,0 @@ - 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 -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. diff --git a/README b/README new file mode 100644 index 0000000..a87c0f8 --- /dev/null +++ b/README @@ -0,0 +1,128 @@ + 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 +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. diff --git a/abcess.h b/abcess.h new file mode 100644 index 0000000..f0ab2ef --- /dev/null +++ b/abcess.h @@ -0,0 +1,56 @@ +/* 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 */ diff --git a/arrgghh.c b/arrgghh.c new file mode 100644 index 0000000..3146bf8 --- /dev/null +++ b/arrgghh.c @@ -0,0 +1,102 @@ +/* + * 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 +#include +#include +#include +#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); + } +} diff --git a/cesspool.c b/cesspool.c new file mode 100644 index 0000000..aebea9a --- /dev/null +++ b/cesspool.c @@ -0,0 +1,624 @@ +/***************************************************************************** + +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 +#include +#include + +#ifdef _POSIX_SOURCE +#include +#else +#include +#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 */ diff --git a/doc/READ.ME b/doc/READ.ME index 25ac8ed..fd507bf 100644 --- a/doc/READ.ME +++ b/doc/READ.ME @@ -29,7 +29,7 @@ different places, (b) the circuit diagrams present in the paper 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 diff --git a/feh.c b/feh.c new file mode 100644 index 0000000..8203c2c --- /dev/null +++ b/feh.c @@ -0,0 +1,988 @@ +/**************************************************************************** + +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 +#include +#include +#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 */ diff --git a/feh.h b/feh.h new file mode 100644 index 0000000..eb0db84 --- /dev/null +++ b/feh.h @@ -0,0 +1,18 @@ +/* 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 */ diff --git a/fiddle.c b/fiddle.c new file mode 100644 index 0000000..7c18667 --- /dev/null +++ b/fiddle.c @@ -0,0 +1,250 @@ +/* + * 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 */ diff --git a/fiddle.h b/fiddle.h new file mode 100644 index 0000000..b01346f --- /dev/null +++ b/fiddle.h @@ -0,0 +1,12 @@ +/* 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 */ diff --git a/ick-wrap.c b/ick-wrap.c new file mode 100644 index 0000000..1234506 --- /dev/null +++ b/ick-wrap.c @@ -0,0 +1,44 @@ +/* $A.c -- generated C-code file for INTERCAL program $A.i */ + +/* This code is explicitly *not* GPLed. Use, abuse, and redistribute freely */ + +#include +#include +#include + +#include +#include +#include + +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 */ diff --git a/ick.h b/ick.h new file mode 100644 index 0000000..87164e2 --- /dev/null +++ b/ick.h @@ -0,0 +1,88 @@ +/* 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 */ diff --git a/ick.y b/ick.y new file mode 100644 index 0000000..707c0a1 --- /dev/null +++ b/ick.y @@ -0,0 +1,377 @@ +/***************************************************************************** + +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 +#include +#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 NUMBER UNARY OHOHSEVEN GERUND LABEL +%token 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 expr varlist variable constant lvalue inlist outlist +%type subscr byexpr scalar array initem outitem sublist +%type unambig subscr1 sublist1 oparray osubscr osubscr1 +%type perform +%type 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 */ diff --git a/intercal.lsm b/intercal.lsm deleted file mode 100644 index 25d84ce..0000000 --- a/intercal.lsm +++ /dev/null @@ -1,19 +0,0 @@ -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 - - diff --git a/intercal.spec b/intercal.spec new file mode 100644 index 0000000..2355474 --- /dev/null +++ b/intercal.spec @@ -0,0 +1,37 @@ +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 diff --git a/lexer.l b/lexer.l new file mode 100644 index 0000000..1b6f975 --- /dev/null +++ b/lexer.l @@ -0,0 +1,380 @@ +%{ +/* + * 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 +#include +#include +#include +#include +#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 */ diff --git a/lose.c b/lose.c new file mode 100644 index 0000000..1e19410 --- /dev/null +++ b/lose.c @@ -0,0 +1,43 @@ +/* + * + * 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 +#include +#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 */ + + diff --git a/lose.h b/lose.h new file mode 100644 index 0000000..76bad13 --- /dev/null +++ b/lose.h @@ -0,0 +1,127 @@ +/* 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 */ diff --git a/numerals.c b/numerals.c new file mode 100644 index 0000000..c4a200e --- /dev/null +++ b/numerals.c @@ -0,0 +1,163 @@ +/* + * 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 */ diff --git a/perpetrate.c b/perpetrate.c new file mode 100644 index 0000000..a92c424 --- /dev/null +++ b/perpetrate.c @@ -0,0 +1,512 @@ +/**************************************************************************** + +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 +#include +#include +#include +#include +#include +#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] [ ... ]\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\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 */ diff --git a/pit/CATALOG b/pit/CATALOG index 20d55b8..bc42d9f 100644 --- a/pit/CATALOG +++ b/pit/CATALOG @@ -1,9 +1,6 @@ -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. @@ -91,6 +88,9 @@ By Brian Raiter 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 diff --git a/pit/Makefile b/pit/Makefile index 3b7e184..3658fba 100644 --- a/pit/Makefile +++ b/pit/Makefile @@ -2,7 +2,7 @@ # Torture-tester for the INTERCAL compiler # -ICK = ../src/ick -b +ICK = ../ick -b SOURCES = \ ./sample.i \ diff --git a/pit/tests/knuth.i b/pit/tests/knuth.i new file mode 100644 index 0000000..738e3d0 --- /dev/null +++ b/pit/tests/knuth.i @@ -0,0 +1,20 @@ + 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 diff --git a/pit/tests/testi18n.i b/pit/tests/testi18n.i new file mode 100644 index 0000000..2106dce --- /dev/null +++ b/pit/tests/testi18n.i @@ -0,0 +1,9 @@ + 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 diff --git a/sizes.h b/sizes.h new file mode 100644 index 0000000..a344bc7 --- /dev/null +++ b/sizes.h @@ -0,0 +1,9 @@ +/* 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 */ diff --git a/specgen.sh b/specgen.sh new file mode 100755 index 0000000..86694ef --- /dev/null +++ b/specgen.sh @@ -0,0 +1,46 @@ +#!/bin/sh + +version=$1 + +cat < support; -# otherwise, the ANSI-compliant 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) diff --git a/src/abcess.h b/src/abcess.h deleted file mode 100644 index f0ab2ef..0000000 --- a/src/abcess.h +++ /dev/null @@ -1,56 +0,0 @@ -/* 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 */ diff --git a/src/arrgghh.c b/src/arrgghh.c deleted file mode 100644 index 98cc290..0000000 --- a/src/arrgghh.c +++ /dev/null @@ -1,101 +0,0 @@ -/* - * 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 -#include -#include -#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); - } -} diff --git a/src/cesspool.c b/src/cesspool.c deleted file mode 100644 index 33355aa..0000000 --- a/src/cesspool.c +++ /dev/null @@ -1,623 +0,0 @@ -/***************************************************************************** - -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 -#include - -#ifdef _POSIX_SOURCE -#include -#else -#include -#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 */ diff --git a/src/feh.c b/src/feh.c deleted file mode 100644 index 8203c2c..0000000 --- a/src/feh.c +++ /dev/null @@ -1,988 +0,0 @@ -/**************************************************************************** - -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 -#include -#include -#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 */ diff --git a/src/feh.h b/src/feh.h deleted file mode 100644 index eb0db84..0000000 --- a/src/feh.h +++ /dev/null @@ -1,18 +0,0 @@ -/* 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 */ diff --git a/src/fiddle.c b/src/fiddle.c deleted file mode 100644 index 7c18667..0000000 --- a/src/fiddle.c +++ /dev/null @@ -1,250 +0,0 @@ -/* - * 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 */ diff --git a/src/fiddle.h b/src/fiddle.h deleted file mode 100644 index b01346f..0000000 --- a/src/fiddle.h +++ /dev/null @@ -1,12 +0,0 @@ -/* 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 */ diff --git a/src/ick-wrap.c b/src/ick-wrap.c deleted file mode 100644 index 1234506..0000000 --- a/src/ick-wrap.c +++ /dev/null @@ -1,44 +0,0 @@ -/* $A.c -- generated C-code file for INTERCAL program $A.i */ - -/* This code is explicitly *not* GPLed. Use, abuse, and redistribute freely */ - -#include -#include -#include - -#include -#include -#include - -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 */ diff --git a/src/ick.h b/src/ick.h deleted file mode 100644 index 87164e2..0000000 --- a/src/ick.h +++ /dev/null @@ -1,88 +0,0 @@ -/* 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 */ diff --git a/src/ick.y b/src/ick.y deleted file mode 100644 index 100ed85..0000000 --- a/src/ick.y +++ /dev/null @@ -1,376 +0,0 @@ -/***************************************************************************** - -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 -#include -#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 NUMBER UNARY OHOHSEVEN GERUND LABEL -%token 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 expr varlist variable constant lvalue inlist outlist -%type subscr byexpr scalar array initem outitem sublist -%type unambig subscr1 sublist1 oparray osubscr osubscr1 -%type perform -%type 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 */ diff --git a/src/lexer.l b/src/lexer.l deleted file mode 100644 index 1b6f975..0000000 --- a/src/lexer.l +++ /dev/null @@ -1,380 +0,0 @@ -%{ -/* - * 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 -#include -#include -#include -#include -#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 */ diff --git a/src/lose.c b/src/lose.c deleted file mode 100644 index 1e19410..0000000 --- a/src/lose.c +++ /dev/null @@ -1,43 +0,0 @@ -/* - * - * 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 -#include -#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 */ - - diff --git a/src/lose.h b/src/lose.h deleted file mode 100644 index 3c24648..0000000 --- a/src/lose.h +++ /dev/null @@ -1,127 +0,0 @@ -/* 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 */ diff --git a/src/numerals.c b/src/numerals.c deleted file mode 100644 index c4a200e..0000000 --- a/src/numerals.c +++ /dev/null @@ -1,163 +0,0 @@ -/* - * 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 */ diff --git a/src/perpetrate.c b/src/perpetrate.c deleted file mode 100644 index a92c424..0000000 --- a/src/perpetrate.c +++ /dev/null @@ -1,512 +0,0 @@ -/**************************************************************************** - -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 -#include -#include -#include -#include -#include -#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] [ ... ]\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\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 */ diff --git a/src/pit/CATALOG b/src/pit/CATALOG deleted file mode 100644 index bc42d9f..0000000 --- a/src/pit/CATALOG +++ /dev/null @@ -1,117 +0,0 @@ -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 - sink.i Simple test program - random.i Random number program - lib/plus.i Increment .1 - -by Hans Olsson - 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 - 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 - beer.i Print out the lyrics to "99 Bottles of Beer On The Wall" - -by Stinglai Ka'abi : - random2.i Another random-number generator - -by Jacob Mandelson - rot13.i Prints ROT-13 of its input - -by Jan-Pieter Cornet - 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 - rot13b.i Another ROT-13 program - -By Brian Raiter - 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 -------------------- diff --git a/src/sizes.h b/src/sizes.h deleted file mode 100644 index a344bc7..0000000 --- a/src/sizes.h +++ /dev/null @@ -1,9 +0,0 @@ -/* 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 */