intercal-0.29/0000755000175000017500000000000011545350336013126 5ustar brooniebroonieintercal-0.29/NEWS0000644000175000017500000000101711475722406013627 0ustar brooniebroonie This is the short-form history of the project, used mainly for generating release announcements via shipper. For the long form, see the file HISTORY. * 0.29: 2010-11-28 The first merged release from ESR and Alex Smith, with encouragement from Donald Knuth. The compiler now has a regression-test suite. More error checks (E990 and E004) have been added. A new program, guess.i, writhes in the pit. The mystery and history of the "Atari implementation" has been clarified. Various minor bugs have been fixed. intercal-0.29/PaxHeaders.9599/0000755000175000017500000000000011577237112015571 5ustar brooniebroonieintercal-0.29/PaxHeaders.9599/NEWS0000644000175000017500000000013111545350336016262 0ustar brooniebroonie30 mtime=1291298054.964014151 29 atime=1301663961.12275129 30 ctime=1301663961.694751849 intercal-0.29/PaxHeaders.9599/src0000644000175000017500000000013211545350337016277 0ustar brooniebroonie30 mtime=1301663964.914750737 30 atime=1301663966.034750704 30 ctime=1301663964.914750737 intercal-0.29/PaxHeaders.9599/doc0000644000175000017500000000013211545350336016254 0ustar brooniebroonie30 mtime=1301663965.774750252 30 atime=1301663966.034750704 30 ctime=1301663965.774750252 intercal-0.29/PaxHeaders.9599/COPYING0000644000175000017500000000013011545350337016616 0ustar brooniebroonie30 mtime=1282834124.181909243 30 atime=1298756058.148875244 28 ctime=1301663961.5187537 intercal-0.29/PaxHeaders.9599/MANIFEST0000644000175000017500000000013211545350337016716 0ustar brooniebroonie30 mtime=1301663966.046750786 30 atime=1301663966.002750674 30 ctime=1301663966.046750786 intercal-0.29/PaxHeaders.9599/HISTORY0000644000175000017500000000013211545350337016651 0ustar brooniebroonie30 mtime=1291298054.964014151 30 atime=1298756081.280873642 30 ctime=1301663965.094749368 intercal-0.29/PaxHeaders.9599/buildaux0000644000175000017500000000013211545350337017325 0ustar brooniebroonie30 mtime=1301663965.142751023 30 atime=1301663966.034750704 30 ctime=1301663965.142751023 intercal-0.29/PaxHeaders.9599/README0000644000175000017500000000013211545350336016444 0ustar brooniebroonie30 mtime=1291030107.342112712 30 atime=1298756049.780874539 30 ctime=1301663961.362749719 intercal-0.29/PaxHeaders.9599/control0000644000175000017500000000013211545350337017170 0ustar brooniebroonie30 mtime=1291030107.346113765 30 atime=1298756058.168874447 30 ctime=1301663965.062767145 intercal-0.29/PaxHeaders.9599/etc0000644000175000017500000000013211545350336016262 0ustar brooniebroonie30 mtime=1284376816.284148473 30 atime=1301663966.034750704 30 ctime=1301663964.806749586 intercal-0.29/PaxHeaders.9599/pit0000644000175000017500000000013211545350337016304 0ustar brooniebroonie30 mtime=1301663965.994751364 30 atime=1301663966.034750704 30 ctime=1301663965.994751364 intercal-0.29/PaxHeaders.9599/prebuilt0000644000175000017500000000013211545350336017335 0ustar brooniebroonie30 mtime=1301663965.866749923 30 atime=1301663966.034750704 30 ctime=1301663965.866749923 intercal-0.29/PaxHeaders.9599/BUGS0000644000175000017500000000013211545350336016247 0ustar brooniebroonie30 mtime=1284376816.208149787 30 atime=1298756050.056874544 30 ctime=1301663964.814770965 intercal-0.29/PaxHeaders.9599/configure.ac0000644000175000017500000000013211545350337020053 0ustar brooniebroonie30 mtime=1291298054.988538754 30 atime=1301663590.176906101 30 ctime=1301663961.370751821 intercal-0.29/PaxHeaders.9599/aclocal.m40000644000175000017500000000013211545350336017424 0ustar brooniebroonie30 mtime=1301663592.862750821 30 atime=1301663593.542750616 30 ctime=1301663961.374752733 intercal-0.29/PaxHeaders.9599/configure0000644000175000017500000000013111545350337017470 0ustar brooniebroonie30 mtime=1301663594.518749902 29 atime=1301663597.61075072 30 ctime=1301663961.678750996 intercal-0.29/src/0000755000175000017500000000000011545350334013713 5ustar brooniebroonieintercal-0.29/src/numerals.c0000644000175000017500000001064611443403052015705 0ustar brooniebroonie/* * 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 ick_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. */ #include "config.h" typedef struct { /*@observer@*/ const char *name; const int value; } numeral; const numeral ick_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 */ intercal-0.29/src/ick_bool.h0000644000175000017500000000126011450066603015642 0ustar brooniebroonie/* * Hide difference between compilers with the C99 bool type and those without. * The main reason this is desirable is so splint can do more rigorous checking * on bools. This also allows for compilers that define _Bool but not true or * false, etc. */ /*@-redef@ -incondefs*/ #ifndef __bool_true_false_are_defined # if HAVE_STDBOOL_H >= 1 # include # else # if !defined(HAVE__BOOL) || HAVE__BOOL < 1 # if HAVE_STDINT_H >= 1 # include typedef int_fast8_t bool; # else typedef int bool; # endif # else typedef _Bool bool; # endif # define true 1 # define false 0 # define __bool_true_false_are_defined 1 # endif #endif /*@=redef =incondefs@*/ intercal-0.29/src/pickwrap.c0000644000175000017500000000124211435477314015704 0ustar brooniebroonie$L /* $A.c -- generated PIC C-code file for INTERCAL program $A.i */ /* This code is explicitly *not* GPLed. Use, abuse, and redistribute freely */ $M $E $K #define ICKABSTAINED(d) abstain##d #define ICKSTASH(a,b,c,d) c##ick_stash[b]=c[b] #define ICKRETRIEVE(a,b,c,d,e) a[b]=a##ick_stash[b] #define ICKIGNORE(a,b,c) ignore##c##b ICK_INT16 ick_skipto=0; $O $C $D $P int ick_main(void) { pickinit(); /* degenerated code */ ick_restart: top: switch(ick_skipto) { case 0: $G } #ifdef YUK if(yukloop) goto ick_restart; #endif ick_lose(IE633, $J, (const char *)0); $H return 0; } $Q /* Generated code for $A.i ends here */ intercal-0.29/src/idiotism.oil0000644000175000017500000006147611443404360016253 0ustar brooniebroonie; ; NAME ; idiotism.oil -- optimizer idioms for C-INTERCAL ; ; LICENSE TERMS ; Copyright (C) 2007 Alex Smith ; ; 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. ; ; Optimizer Idiom Language input file for C-INTERCAL ; See the appendix "Optimizer Idiom Language" in the Revamped manual ; for information about the format of this file. ; Some useful constants: ; 0x55555555 1431655765 ; 0xAAAAAAAA 2863311530 ; 0x0000FFFF 65535 ; 0xFFFF0000 4294901760 ; 0xFFFFFFFF 4294967295 ; Constant folding [minglefold] (#{x<=65535}1$#{x<=65535}2)->(#{mingle(x1,x2)}0) [selectfold] (#{1}1~#{1}2)->(#{iselect(x1,x2)}0) [and32fold] (&32 #{1}1)->(#{and32(x1)}0) [or32fold] (V32 #{1}1)->(#{or32(x1)}0) [xor32fold] (?32 #{1}1)->(#{xor32(x1)}0) [and16fold] (&16 #{1}1)->(#{and16(x1)}0) [or16fold] (V16 #{1}1)->(#{or16(x1)}0) [xor16fold] (?16 #{1}1)->(#{xor16(x1)}0) ; C operations can, and should, be folded too [cfold] (#{1}1 & #{1}2)->(#{x1 & x2}0) (#{1}1 | #{1}2)->(#{x1 | x2}0) (#{1}1 ^ #{1}2)->(#{x1 ^ x2}0) (#{1}1 + #{1}2)->(#{x1 + x2}0) (#{1}1 - #{1}2)->(#{x1 - x2}0) (#{1}1 * #{1}2)->(#{x1 * x2}0) (#{1}1 / #{1}2)->(#{x1 / x2}0) (#{1}1 % #{1}2)->(#{x1 % x2}0) (#{1}1 > #{1}2)->(#{x1 > x2}0) (#{1}1 < #{1}2)->(#{x1 < x2}0) (#{1}1 >> #{1}2)->(#{x1 >> x2}0) (#{1}1 << #{1}2)->(#{x1 << x2}0) (#{1}1 == #{1}2)->(#{x1 == x2}0) (#{1}1 != #{1}2)->(#{x1 != x2}0) (! #{1}1)->(#{!x1}0) ; Reducing constants inside a C or operation can help to recognize idioms [cfoldintoorinand] (((_1) | #{(x != (x & x3))}2) & #{1}3)->(((_1) | #{x2 & x3}0) & _3) ; Binary bitwise optimizations [cbinand] ((&32(_{!(c&4294901760LU)}1$_{!(c&4294901760LU)}2))~ #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->((_1 & _2) & #{iselect(x3,1431655765LU)}0) [cbinor] ((V32(_{!(c&4294901760LU)}1$_{!(c&4294901760LU)}2))~ #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->((_1 | _2) & #{iselect(x3,1431655765LU)}0) [cbinxor] ((?32(_{!(c&4294901760LU)}1$_{!(c&4294901760LU)}2))~ #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->((_1 ^ _2) & #{iselect(x3,1431655765LU)}0) ; Sometimes, an expanded output is wanted, optimizations happen in the wrong ; order, and we end up with & rather than ~ on the previous idiom. Correct ; such situations now. [cbinandnoselect] ((&32(_{!(c&4294901760LU)}1$_{!(c&4294901760LU)}2))& #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(#0 $ ((_1 & _2) & #{iselect(x3,1431655765LU)}0)) [cbinornoselect] ((V32(_{!(c&4294901760LU)}1$_{!(c&4294901760LU)}2))& #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(#0 $ ((_1 | _2) & #{iselect(x3,1431655765LU)}0)) [cbinxornoselect] ((?32(_{!(c&4294901760LU)}1$_{!(c&4294901760LU)}2))& #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(#0 $ ((_1 ^ _2) & #{iselect(x3,1431655765LU)}0)) ; Sometimes, there isn't even a mingle... [cbinandnomingle] ((&32(_{!(c&2863311530LU)}1|_{!(c&1431655765LU)}2))~ #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(((_2 >> #1) & _1) ~ _3) ((&32(_{!(c&1431655765LU)}2|_{!(c&2863311530LU)}1))~ #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(((_2 >> #1) & _1) ~ _3) ((&32(_{!(c&2863311530LU)}1|_{!(c&1431655765LU)}2))& #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(((_2 >> #1) & _1) & _3) ((&32(_{!(c&1431655765LU)}2|_{!(c&2863311530LU)}1))& #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(((_2 >> #1) & _1) & _3) [cbinornomingle] ((V32(_{!(c&2863311530LU)}1|_{!(c&1431655765LU)}2))~ #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(((_2 >> #1) | _1) ~ _3) ((V32(_{!(c&1431655765LU)}2|_{!(c&2863311530LU)}1))~ #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(((_2 >> #1) | _1) ~ _3) ((V32(_{!(c&2863311530LU)}1|_{!(c&1431655765LU)}2))& #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(((_2 >> #1) | _1) & _3) ((V32(_{!(c&1431655765LU)}2|_{!(c&2863311530LU)}1))& #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(((_2 >> #1) | _1) & _3) [cbinxornomingle] ((?32(_{!(c&2863311530LU)}1|_{!(c&1431655765LU)}2))~ #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(((_2 >> #1) ^ _1) ~ _3) ((?32(_{!(c&1431655765LU)}2|_{!(c&2863311530LU)}1))~ #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(((_2 >> #1) ^ _1) ~ _3) ((?32(_{!(c&2863311530LU)}1|_{!(c&1431655765LU)}2))& #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(((_2 >> #1) ^ _1) & _3) ((?32(_{!(c&1431655765LU)}2|_{!(c&2863311530LU)}1))& #{!(x&2863311530LU)&&iselect(x,1431655765LU)==xselx(iselect(x,1431655765LU))}3 )->(((_2 >> #1) ^ _1) & _3) ; Bitwise complements. (The INTERCAL which ultimately leads to cases 3 and 4 ; is not the most efficient way to do this, by the way.) [cnot1] (#65535 ^ .{!(c&4294901760LU)}1)->(~16 .1) [cnot2] (.{!(c&4294901760LU)}1 ^ #65535)->(~16 .1) [cnot3] (#4294967295 ^ :1)->(~32 :1) [cnot4] (:1 ^ #4294967295)->(~32 :1) ; bitwise logical equivalence [cxorand16] ((.1 ^ .2) & .2)->((~16 .1) & .2) ((.2 ^ .1) & .2)->((~16 .1) & .2) ((.1 & .2) ^ .2)->((~16 .1) & .2) ((.2 & .1) ^ .2)->((~16 .1) & .2) (.2 ^ (.1 & .2))->((~16 .1) & .2) (.2 ^ (.2 & .1))->((~16 .1) & .2) (.2 & (.1 ^ .2))->((~16 .1) & .2) (.2 & (.2 ^ .1))->((~16 .1) & .2) [cxorandmixed] ; This requires typecasting .1 to 32 bits. ((.1 ^ :2) & :2)->((~32 .1) & :2) ((:2 ^ .1) & :2)->((~32 .1) & :2) ((.1 & :2) ^ :2)->((~32 .1) & :2) ((:2 & .1) ^ :2)->((~32 .1) & :2) (:2 ^ (.1 & :2))->((~32 .1) & :2) (:2 ^ (:2 & .1))->((~32 .1) & :2) (:2 & (.1 ^ :2))->((~32 .1) & :2) (:2 & (:2 ^ .1))->((~32 .1) & :2) [cxorand32] ((:1 ^ _2) & _2)->((~32 _1) & _2) ((_2 ^ :1) & _2)->((~32 _1) & _2) ((:1 & _2) ^ _2)->((~32 _1) & _2) ((_2 & :1) ^ _2)->((~32 _1) & _2) (_2 ^ (:1 & _2))->((~32 _1) & _2) (_2 ^ (_2 & :1))->((~32 _1) & _2) (_2 & (:1 ^ _2))->((~32 _1) & _2) (_2 & (_2 ^ :1))->((~32 _1) & _2) ; Special cases of select ; Selecting the rightmost bits of a number [xselpow2m1] (_1 ~ #{x==xselx(x)}2)->(_1 & _2) ; Selecting one bit from a number [xselpow2] (_1 ~ #{xselx(x)==1}2)->(!(!(_1 & _2))) ; Selecting a number against itself and then selecting 1 from that [xselxsel1] ((_1~_1)~#1)->(!(!_1)) ((_1~_1))->(!(!_1)) (#1&(_1~_1))->(!(!_1)) ((_1~_1)&_{c==1}2)->(_1 && _2) (_{c==1}2&(_1~_1))->(_1 && _2) ; Selecting a number from a constant that's just below a power of 2 [pow2m1selx] ((#{x==xselx(x)}1 ~ _2) ~ #1)->(!(!(_1 & _2))) ; Boolean-negating a select [notselect] (!(_1~_2))->(!(_1&_2)) ; Sometimes select and mingle cancel each other out [selectmingle1] ((_1~#2863311530)$_2)->((_1�)|(#0$_2)) [selectmingle2] (_1$(_2~#1431655765))->((_1$#0)|(_2�)) [selectmingle3] ((_1~#1431655765)$_2)->(((_1�)<<#1)|(#0$_2)) [selectmingle4] (_1$(_2~#2863311530))->(((_2�)>>#1)|(_1$#0)) [selectmingle5] ;3579139412=0xd5555554 ((_{!(c&4294901760UL)}1$_{!(c&4294901760UL)}2)~#3579139412) ->((_1耀)|(_2>>#1)) ; special cases of V16/?16; the top bit was 0, so becomes equal to the ; bottom bit [or16and] ((V16 _{!(c&4294934528UL)}1)耀)->((_1)<<#15) [xor16and] ((?16 _{!(c&4294934528UL)}1)耀)->((_1)<<#15) ; Shifts ; Rightshift some of the bits [rshift] <#1-#31 (_1~#{xselx(x)<((_1&_2)>>#{r}0) > ; General 16-bit leftshifts ; ; Large left-shifts can be written in an optimized way using knowledge of the ; rightmost bits to shift more than one bit at a time. ; If the rightmost few bits of a number are known to be 0, it can be mingled ; with 0, and then selected with a number which has many 0s to do a leftshift. ; Here, if none of the bits marked l are set this is a right-shift by 3, and ; for each bit set, the shift goes 1 leftwards. ; (xxxxxxxxxxxxxttt $ 000000000000uuuu) ~ (h0h0h0h0h0h0h0h0h0h0h0h01lllllll) ; x0x0x0x0x0x0x0x0x0x0x0x0xutututu ; h0h0h0h0h0h0h0h0h0h0h0h01lllllll ; There's three cases here for each possible width for the ts, including one ; which has them as zeros and two which have them higher. [lshift16] <#0-#14 ((_{c<=65535&&!(c&((1LU<((((_1>>#{r}0)~#{iselect(x3>>(r*2+1),1431655765LU)}0) <<#{setbitcount(x3&((2LU<<(r*2))-1))}0)|#{iselect(mingle(0,x2),x3)}0) (((_{c<=65535&&!(c&((1LU<((((_1>>#{r}0)~#{iselect(x3>>(r*2+1),1431655765LU)}0) <<#{setbitcount(x3&((2LU<<(r*2))-1))}0)|#{iselect(mingle(x4,x2),x3)}0) (((#{x<=65535&&!(c&~((1LU<((((_1>>#{r}0)~#{iselect(x3>>(r*2+1),1431655765LU)}0) <<#{setbitcount(x3&((2LU<<(r*2))-1))}0)|#{iselect(mingle(x4,x2),x3)}0) > ; A helper in calculating 32-bit shifts; this is a shift on half the bits of ; a 32-bit number. [lshift32half] (#0$((:1~#715827882)<<#1))->((:1�)<<#1) (#0$((:1�)~#715827883))->((:1�)<<#1) ; 32-bit leftshift by 1; there are 8 ways to write this. [lshift32by1] (((_1�)<<#1)|((_1�)<<#1))->((_1�)<<#1) (((#1431655765&_1)<<#1)|((_1�)<<#1))->((_1�)<<#1) (((_1�)<<#1)|((#715827882&_1)<<#1))->((_1�)<<#1) (((#1431655765&_1)<<#1)|((#715827882&_1)<<#1))->((_1�)<<#1) (((_1�)<<#1)|((_1�)<<#1))->((_1�)<<#1) (((_1�)<<#1)|((#1431655765&_1)<<#1))->((_1�)<<#1) (((#715827882&_1)<<#1)|((_1�)<<#1))->((_1�)<<#1) (((#715827882&_1)<<#1)|((#1431655765&_1)<<#1))->((_1�)<<#1) ; Move rshift, AND out of neg [rshiftoutofneg] (~16 (.1 >> #1))->(((~16 .1) >> #1) | #32768) (~32 (:1 >> #1))->(((~32 :1) >> #1) | #2147483648) [andoutofneg] (~16 (.1 & #{1}2))->(((~16 .1) & _2) | #{(~x2)&65535}0) (~32 (:1 & #{1}2))->(((~32 :1) & _2) | #{~x2}0) ; Move AND inside shifts, and OR and XOR outside shifts [andintoshift] ((_1 << #{1}2) & #{1}3)->((_1 & #{x3>>x2}0) << _2) ((_1 >> #{1}2) & #{1}3)->((_1 & #{x3<> _2) [oroutofshift] ((_1 | #{1}2) << #{1}3)->((_1 << _3) | #{x2<> #{1}3)->((_1 >> _3) | #{x2>>x3}0) [xoroutofshift] ((_1 ^ #{1}2) << #{1}3)->((_1 << _3) ^ #{x2<> #{1}3)->((_1 >> _3) ^ #{x2>>x3}0) ; Larger leftshifts can be created by combining smaller ones, although there ; are shortcuts that can be used and this idiom only works if they haven't ; been. Also, idioms later on can create shifts that cancel each other out, so ; the code for cancelling them is here. [combinellshift] ((_1 << #{1}2) << #{1}3)->(_1 << #{x2+x3}0) [combinelrshift] ((.{65535LU>>x2 >= c}1 << #{1}2) >> #{x>x2}3)->(.1 >> #{x3-x2}0) ((.{65535LU>>x2 >= c}1 << #{1}2) >> #{x==x2}3)->(.1) ((.{65535LU>>x2 >= c}1 << #{1}2) >> #{x(.1 << #{x2-x3}0) ((:{4294967295LU>>x2 >= c}1 << #{1}2) >> #{x>x2}3)->(:1 >> #{x3-x2}0) ((:{4294967295LU>>x2 >= c}1 << #{1}2) >> #{x==x2}3)->(:1) ((:{4294967295LU>>x2 >= c}1 << #{1}2) >> #{x(:1 << #{x2-x3}0) [combinerlshift] ((_{!(((1LU<> #{1}2) << #{x>x2}3)->(_1 << #{x3-x2}0) ((_{!(((1LU<> #{1}2) << #{x==x2}3)->(_1) ((_{!(((1LU<> #{1}2) << #{x(_1 >> #{x2-x3}0) [combinerrshift] ((_1 >> #{1}2) >> #{1}3)->(_1 >> #{x2+x3}0) [nullshift] (_1 >> #0)->(_1) (_1 << #0)->(_1) ; INTERCAL logical values are 1 and 2. [xorto1or2] ((?32(_{!(c&4294901760LU)}1$#1)))->((_1)+#1) ((?32(_{!(c&4294901760LU)}1$#2)))->(#2-(_1)) ; Removing, combining and weakening unneeded C_ANDs [unneededand] (_1&#{!(c1&~x)}0)->(_1) (#{!(c1&~x)}0&_1)->(_1) [combineand] ((_1&#{1}2)&#{1}3)->(_1&#{x2&x3}0) ((#{1}2&_1)&#{1}3)->(_1&#{x2&x3}0) (#{1}3&(_1&#{1}2))->(_1&#{x2&x3}0) (#{1}3&(#{1}2&_1))->(_1&#{x2&x3}0) [weakenand] (_1&#{(~c1)&x}2)->(_1&#{c1&x2}0) (#{(~c1)&x}2&_1)->(_1&#{c1&x2}0) ; 32-bit complements ; Complement odd bits, zero even bits [com1z0] (((?32(_1|#1431655765))�)<<#1)->((_1�)^#2863311530) (((?32(#1431655765|_1))�)<<#1)->((_1�)^#2863311530) ((#1431655765&(?32(_1|#1431655765)))<<#1)->((_1�)^#2863311530) ((#1431655765&(?32(#1431655765|_1)))<<#1)->((_1�)^#2863311530) ; Complement even bits, zero odd bits [com0z1] ((?32(((_1�)<<#1)|#1431655765))�) ->((_1�)^#1431655765) ((?32(((#1431655765&_1)<<#1)|#1431655765))�) ->((_1�)^#1431655765) ((?32(#1431655765|((_1�)<<#1)))�) ->((_1�)^#1431655765) ((?32(#1431655765|((#1431655765&_1)<<#1)))�) ->((_1�)^#1431655765) (#1431655765&(?32(((_1�)<<#1)|#1431655765))) ->((_1�)^#1431655765) (#1431655765&(?32(((#1431655765&_1)<<#1)|#1431655765))) ->((_1�)^#1431655765) (#1431655765&(?32(#1431655765|((_1�)<<#1)))) ->((_1�)^#1431655765) (#1431655765&(?32(#1431655765|((#1431655765&_1)<<#1)))) ->((_1�)^#1431655765) ; 32-bit complements, in full [cnot5] (((:1&#{1}2)^#{x==x2}0)|((:1&#{(x^x2)==4294967295LU}3)^#{x==x3}0))->(~32 :1) ; Distributive laws ; Several of these laws go towards helping finish off 32-bit C binary logical ; operations, but are useful in other places as well (especially distributions ; involving shifts). [distribll] ((_1&_3)&(_2&_3))->((_1&_2)&_3) ((_1|_3)&(_2|_3))->((_1&_2)|_3) ((_1&_3)|(_2&_3))->((_1|_2)&_3) ((_1|_3)|(_2|_3))->((_1|_2)|_3) ((_1&_3)^(_2&_3))->((_1^_2)&_3) ((_1<<_3)&(_2<<_3))->((_1&_2)<<_3) ((_1<<_3)|(_2<<_3))->((_1|_2)<<_3) ((_1<<_3)^(_2<<_3))->((_1^_2)<<_3) ((_1>>_3)&(_2>>_3))->((_1&_2)>>_3) ((_1>>_3)|(_2>>_3))->((_1|_2)>>_3) ((_1>>_3)^(_2>>_3))->((_1^_2)>>_3) [distribrl] ((_3&_1)&(_2&_3))->((_1&_2)&_3) ((_3|_1)&(_2|_3))->((_1&_2)|_3) ((_3&_1)|(_2&_3))->((_1|_2)&_3) ((_3|_1)|(_2|_3))->((_1|_2)|_3) ((_3&_1)^(_2&_3))->((_1^_2)&_3) [distriblr] ((_1&_3)&(_3&_2))->((_1&_2)&_3) ((_1|_3)&(_3|_2))->((_1&_2)|_3) ((_1&_3)|(_3&_2))->((_1|_2)&_3) ((_1|_3)|(_3|_2))->((_1|_2)|_3) ((_1&_3)^(_3&_2))->((_1^_2)&_3) [distribrr] ((_3&_1)&(_3&_2))->((_1&_2)&_3) ((_3|_1)&(_3|_2))->((_1&_2)|_3) ((_3&_1)|(_3&_2))->((_1|_2)&_3) ((_3|_1)|(_3|_2))->((_1|_2)|_3) ((_3&_1)^(_3&_2))->((_1^_2)&_3) [distribunary] ((!_1)&(!_2))->(!(_1|_2)) ; 32-bit C binary logical operations ; Strangely enough, these can be done for the most part with the combined ; effect of many small optimizations (of course, that's the best way to do it). ; The only potential problem is that the distributive law isn't quite general ; enough for some cases involving constants, and for some cases where one side ; or the other is known to have no set evenbits or no set oddbits. ; Some generalised versions of the distributive law are needed here. ; Unfortunately, there are lots of binary operators here that need to be ; written both ways round. The 96 cases that follow, combined with weakenand, ; should be enough for all but the most pathological cases. [distribhalfxoroveror1] (((_1 ^ _2) & _3) | (_1 & _{(c&c3)==0}4))->((_1 & (_3 | _4)) ^ (_2 & _3)) ((_1 & _{(c&c3)==0}4) | ((_1 ^ _2) & _3))->((_1 & (_3 | _4)) ^ (_2 & _3)) (((_1 ^ _2) & _3) | (_{(c&c3)==0}4 & _1))->((_1 & (_3 | _4)) ^ (_2 & _3)) ((_{(c&c3)==0}4 & _1) | ((_1 ^ _2) & _3))->((_1 & (_3 | _4)) ^ (_2 & _3)) ((_3 & (_1 ^ _2)) | (_1 & _{(c&c3)==0}4))->((_1 & (_3 | _4)) ^ (_2 & _3)) ((_1 & _{(c&c3)==0}4) | (_3 & (_1 ^ _2)))->((_1 & (_3 | _4)) ^ (_2 & _3)) ((_3 & (_1 ^ _2)) | (_{(c&c3)==0}4 & _1))->((_1 & (_3 | _4)) ^ (_2 & _3)) ((_{(c&c3)==0}4 & _1) | (_3 & (_1 ^ _2)))->((_1 & (_3 | _4)) ^ (_2 & _3)) (((_2 ^ _1) & _3) | (_1 & _{(c&c3)==0}4))->((_1 & (_3 | _4)) ^ (_2 & _3)) ((_1 & _{(c&c3)==0}4) | ((_2 ^ _1) & _3))->((_1 & (_3 | _4)) ^ (_2 & _3)) (((_2 ^ _1) & _3) | (_{(c&c3)==0}4 & _1))->((_1 & (_3 | _4)) ^ (_2 & _3)) ((_{(c&c3)==0}4 & _1) | ((_2 ^ _1) & _3))->((_1 & (_3 | _4)) ^ (_2 & _3)) ((_3 & (_2 ^ _1)) | (_1 & _{(c&c3)==0}4))->((_1 & (_3 | _4)) ^ (_2 & _3)) ((_1 & _{(c&c3)==0}4) | (_3 & (_2 ^ _1)))->((_1 & (_3 | _4)) ^ (_2 & _3)) ((_3 & (_2 ^ _1)) | (_{(c&c3)==0}4 & _1))->((_1 & (_3 | _4)) ^ (_2 & _3)) ((_{(c&c3)==0}4 & _1) | (_3 & (_2 ^ _1)))->((_1 & (_3 | _4)) ^ (_2 & _3)) [distribhalfxoroveror2] (((_1 & _3) ^ _{(c&c3)==c}2) | (_1 & _{(c&c3)==0}4))->((_1 ^ _2) & (_3 | _4)) ((_1 & _{(c&c3)==0}4) | ((_1 & _3) ^ _{(c&c3)==c}2))->((_1 ^ _2) & (_3 | _4)) (((_1 & _3) ^ _{(c&c3)==c}2) | (_{(c&c3)==0}4 & _1))->((_1 ^ _2) & (_3 | _4)) ((_{(c&c3)==0}4 & _1) | ((_1 & _3) ^ _{(c&c3)==c}2))->((_1 ^ _2) & (_3 | _4)) ((_{(c&c3)==c}2 ^ (_1 & _3)) | (_1 & _{(c&c3)==0}4))->((_1 ^ _2) & (_3 | _4)) ((_1 & _{(c&c3)==0}4) | (_{(c&c3)==c}2 ^ (_1 & _3)))->((_1 ^ _2) & (_3 | _4)) ((_{(c&c3)==c}2 ^ (_1 & _3)) | (_{(c&c3)==0}4 & _1))->((_1 ^ _2) & (_3 | _4)) ((_{(c&c3)==0}4 & _1) | (_{(c&c3)==c}2 ^ (_1 & _3)))->((_1 ^ _2) & (_3 | _4)) (((_3 & _1) ^ _{(c&c3)==c}2) | (_1 & _{(c&c3)==0}4))->((_1 ^ _2) & (_3 | _4)) ((_1 & _{(c&c3)==0}4) | ((_3 & _1) ^ _{(c&c3)==c}2))->((_1 ^ _2) & (_3 | _4)) (((_3 & _1) ^ _{(c&c3)==c}2) | (_{(c&c3)==0}4 & _1))->((_1 ^ _2) & (_3 | _4)) ((_{(c&c3)==0}4 & _1) | ((_3 & _1) ^ _{(c&c3)==c}2))->((_1 ^ _2) & (_3 | _4)) ((_{(c&c3)==c}2 ^ (_3 & _1)) | (_1 & _{(c&c3)==0}4))->((_1 ^ _2) & (_3 | _4)) ((_1 & _{(c&c3)==0}4) | (_{(c&c3)==c}2 ^ (_3 & _1)))->((_1 ^ _2) & (_3 | _4)) ((_{(c&c3)==c}2 ^ (_3 & _1)) | (_{(c&c3)==0}4 & _1))->((_1 ^ _2) & (_3 | _4)) ((_{(c&c3)==0}4 & _1) | (_{(c&c3)==c}2 ^ (_3 & _1)))->((_1 ^ _2) & (_3 | _4)) ; We require bits in common between 1 and 2 to prevent an infinite loop; ; otherwise this swaps (1<=>3, 2<=>4) indefinitely. [distribhalforoveror1] (((_1 | _{c&c1}2) & _3) | (_1 & _{(c&c3)==0}4))->((_1 & (_3 | _4)) | (_2 & _3)) ((_1 & _{(c&c3)==0}4) | ((_1 | _{c&c1}2) & _3))->((_1 & (_3 | _4)) | (_2 & _3)) (((_1 | _{c&c1}2) & _3) | (_{(c&c3)==0}4 & _1))->((_1 & (_3 | _4)) | (_2 & _3)) ((_{(c&c3)==0}4 & _1) | ((_1 | _{c&c1}2) & _3))->((_1 & (_3 | _4)) | (_2 & _3)) ((_3 & (_1 | _{c&c1}2)) | (_1 & _{(c&c3)==0}4))->((_1 & (_3 | _4)) | (_2 & _3)) ((_1 & _{(c&c3)==0}4) | (_3 & (_1 | _{c&c1}2)))->((_1 & (_3 | _4)) | (_2 & _3)) ((_3 & (_1 | _{c&c1}2)) | (_{(c&c3)==0}4 & _1))->((_1 & (_3 | _4)) | (_2 & _3)) ((_{(c&c3)==0}4 & _1) | (_3 & (_1 | _{c&c1}2)))->((_1 & (_3 | _4)) | (_2 & _3)) (((_{c&c1}2 | _1) & _3) | (_1 & _{(c&c3)==0}4))->((_1 & (_3 | _4)) | (_2 & _3)) ((_1 & _{(c&c3)==0}4) | ((_{c&c1}2 | _1) & _3))->((_1 & (_3 | _4)) | (_2 & _3)) (((_{c&c1}2 | _1) & _3) | (_{(c&c3)==0}4 & _1))->((_1 & (_3 | _4)) | (_2 & _3)) ((_{(c&c3)==0}4 & _1) | ((_{c&c1}2 | _1) & _3))->((_1 & (_3 | _4)) | (_2 & _3)) ((_3 & (_{c&c1}2 | _1)) | (_1 & _{(c&c3)==0}4))->((_1 & (_3 | _4)) | (_2 & _3)) ((_1 & _{(c&c3)==0}4) | (_3 & (_{c&c1}2 | _1)))->((_1 & (_3 | _4)) | (_2 & _3)) ((_3 & (_{c&c1}2 | _1)) | (_{(c&c3)==0}4 & _1))->((_1 & (_3 | _4)) | (_2 & _3)) ((_{(c&c3)==0}4 & _1) | (_3 & (_{c&c1}2 | _1)))->((_1 & (_3 | _4)) | (_2 & _3)) [distribhalforoveror2] (((_1 & _3) | _2) | (_1 & _{(c&c3)==0}4))->((_1 & (_3 | _4)) | _2) ((_1 & _{(c&c3)==0}4) | ((_1 & _3) | _2))->((_1 & (_3 | _4)) | _2) (((_1 & _3) | _2) | (_{(c&c3)==0}4 & _1))->((_1 & (_3 | _4)) | _2) ((_{(c&c3)==0}4 & _1) | ((_1 & _3) | _2))->((_1 & (_3 | _4)) | _2) ((_2 | (_1 & _3)) | (_1 & _{(c&c3)==0}4))->((_1 & (_3 | _4)) | _2) ((_1 & _{(c&c3)==0}4) | (_2 | (_1 & _3)))->((_1 & (_3 | _4)) | _2) ((_2 | (_1 & _3)) | (_{(c&c3)==0}4 & _1))->((_1 & (_3 | _4)) | _2) ((_{(c&c3)==0}4 & _1) | (_2 | (_1 & _3)))->((_1 & (_3 | _4)) | _2) (((_3 & _1) | _2) | (_1 & _{(c&c3)==0}4))->((_1 & (_3 | _4)) | _2) ((_1 & _{(c&c3)==0}4) | ((_3 & _1) | _2))->((_1 & (_3 | _4)) | _2) (((_3 & _1) | _2) | (_{(c&c3)==0}4 & _1))->((_1 & (_3 | _4)) | _2) ((_{(c&c3)==0}4 & _1) | ((_3 & _1) | _2))->((_1 & (_3 | _4)) | _2) ((_2 | (_3 & _1)) | (_1 & _{(c&c3)==0}4))->((_1 & (_3 | _4)) | _2) ((_1 & _{(c&c3)==0}4) | (_2 | (_3 & _1)))->((_1 & (_3 | _4)) | _2) ((_2 | (_3 & _1)) | (_{(c&c3)==0}4 & _1))->((_1 & (_3 | _4)) | _2) ((_{(c&c3)==0}4 & _1) | (_2 | (_3 & _1)))->((_1 & (_3 | _4)) | _2) [distribhalfandoveror1] (((_1 & _2) & _3) | (_1 & _{(c&c3)==0}4))->(((_3 & _2) | _4) & _1) ((_1 & _{(c&c3)==0}4) | ((_1 & _2) & _3))->(((_3 & _2) | _4) & _1) (((_1 & _2) & _3) | (_{(c&c3)==0}4 & _1))->(((_3 & _2) | _4) & _1) ((_{(c&c3)==0}4 & _1) | ((_1 & _2) & _3))->(((_3 & _2) | _4) & _1) ((_3 & (_1 & _2)) | (_1 & _{(c&c3)==0}4))->(((_3 & _2) | _4) & _1) ((_1 & _{(c&c3)==0}4) | (_3 & (_1 & _2)))->(((_3 & _2) | _4) & _1) ((_3 & (_1 & _2)) | (_{(c&c3)==0}4 & _1))->(((_3 & _2) | _4) & _1) ((_{(c&c3)==0}4 & _1) | (_3 & (_1 & _2)))->(((_3 & _2) | _4) & _1) (((_2 & _1) & _3) | (_1 & _{(c&c3)==0}4))->(((_3 & _2) | _4) & _1) ((_1 & _{(c&c3)==0}4) | ((_2 & _1) & _3))->(((_3 & _2) | _4) & _1) (((_2 & _1) & _3) | (_{(c&c3)==0}4 & _1))->(((_3 & _2) | _4) & _1) ((_{(c&c3)==0}4 & _1) | ((_2 & _1) & _3))->(((_3 & _2) | _4) & _1) ((_3 & (_2 & _1)) | (_1 & _{(c&c3)==0}4))->(((_3 & _2) | _4) & _1) ((_1 & _{(c&c3)==0}4) | (_3 & (_2 & _1)))->(((_3 & _2) | _4) & _1) ((_3 & (_2 & _1)) | (_{(c&c3)==0}4 & _1))->(((_3 & _2) | _4) & _1) ((_{(c&c3)==0}4 & _1) | (_3 & (_2 & _1)))->(((_3 & _2) | _4) & _1) [distribhalfandoveror2] (((_1 & _3) & _2) | (_1 & _{(c&c3)==0}4))->(((_3 & _2) | _4) & _1) ((_1 & _{(c&c3)==0}4) | ((_1 & _3) & _2))->(((_3 & _2) | _4) & _1) (((_1 & _3) & _2) | (_{(c&c3)==0}4 & _1))->(((_3 & _2) | _4) & _1) ((_{(c&c3)==0}4 & _1) | ((_1 & _3) & _2))->(((_3 & _2) | _4) & _1) ((_2 & (_1 & _3)) | (_1 & _{(c&c3)==0}4))->(((_3 & _2) | _4) & _1) ((_1 & _{(c&c3)==0}4) | (_2 & (_1 & _3)))->(((_3 & _2) | _4) & _1) ((_2 & (_1 & _3)) | (_{(c&c3)==0}4 & _1))->(((_3 & _2) | _4) & _1) ((_{(c&c3)==0}4 & _1) | (_2 & (_1 & _3)))->(((_3 & _2) | _4) & _1) (((_3 & _1) & _2) | (_1 & _{(c&c3)==0}4))->(((_3 & _2) | _4) & _1) ((_1 & _{(c&c3)==0}4) | ((_3 & _1) & _2))->(((_3 & _2) | _4) & _1) (((_3 & _1) & _2) | (_{(c&c3)==0}4 & _1))->(((_3 & _2) | _4) & _1) ((_{(c&c3)==0}4 & _1) | ((_3 & _1) & _2))->(((_3 & _2) | _4) & _1) ((_2 & (_3 & _1)) | (_1 & _{(c&c3)==0}4))->(((_3 & _2) | _4) & _1) ((_1 & _{(c&c3)==0}4) | (_2 & (_3 & _1)))->(((_3 & _2) | _4) & _1) ((_2 & (_3 & _1)) | (_{(c&c3)==0}4 & _1))->(((_3 & _2) | _4) & _1) ((_{(c&c3)==0}4 & _1) | (_2 & (_3 & _1)))->(((_3 & _2) | _4) & _1) ; A right-shift idiom in syslib that was written in an unneccessarily complex ; way, by doing the bits separately the same way as left-shifts have to be done ; (of course, select can right-shift by any difference without much trouble); ; the next idiom is a helper for that. Previous code produced a warning when ; this idiom was used, but the optimizer has now been enhanced to the extent ; that it can deal with it without much special-casing, and therefore there's ; no way now to tell that that case is being used, so the warning has been ; removed. ; lshift32half done in the other direction; note that the large constant here ; is 0x55555554, not the all-5s number [rshift32half] ((_1~#1431655764)$#0)->((_1�)>>#1) ; and piecing together this with selectmingle4 gives the syslib idiom, which ; optimizes through distributions over C_OR and then constant folding ; When a 0 is on one side of a C binary logic operation, or the two sides are ; the same, simplification is often possible. [noopor] (_1|#0)->(_1) (#0|_1)->(_1) [noopxor] (_1^#0)->(_1) (#0^_1)->(_1) [anditself] (_1&_1)->(_1) [and0] (_1�)->(#0) (#0&_1)->(#0) [oritself] (_1|_1)->(_1) [xoritself] (_1^_1)->(#0) ; The following four idioms by JH ((_1^_2)^_1) -> (_2) ((_2^_1)^_1) -> (_2) (_1^(_1^_2)) -> (_2) (_1^(_2^_1)) -> (_2) ; Equality and inequality [xortoequal] (!(_1^_2))->(_1==_2) [negatingequal] (!(_1==_2))->(_1!=_2) (!(_1!=_2))->(_1==_2) ; Greater than and less than [greaterthan32] ((_1~:2)~((?32(:2~:2))^#2147483648))->(_1>(:2^_1)) ((_1~:2)~(#2147483648^(?32(:2~:2))))->(_1>(:2^_1)) [greaterthan16] ((_1~.2)~((?16(.2~.2))^#32768))->(_1>(.2^_1)) ((_1~.2)~(#32768^(?16(.2~.2))))->(_1>(.2^_1)) ; Consistency in C logical operation nesting, when it doesn't matter [xoroutsideand] ((_1^_2)&_2)->((_1&_2)^_2) (_2&(_1^_2))->((_1&_2)^_2) ((_2^_1)&_2)->((_1&_2)^_2) (_2&(_2^_1))->((_1&_2)^_2) ; Boolean algebra, on 0s and 1s or on 1s and 2s. Unary bitwidth is irrelevant. [booleannot] (_{c==1}1^#1)->(!_1) [not21] (#2-(!(_{c==1}1)))->(_1+#1) (#1+(!(_{c==1}1)))->(#2-_1) ((!(_{c==1}1))+#1)->(#2-_1) [nullmingle] (#0$_{c==1}1)->(_1) ; Thanks to Joris Huizer for suggesting the idea behind the next one; ; this is a more general idiom than the suggested [triplenot]. [redundantdoublenot] (!(!(_{c==1}1)))->(_1) intercal-0.29/src/pick2.h0000644000175000017500000001065111435477314015105 0ustar brooniebroonie/* * pick2.h - Runtime library for INTERCAL, for use by PIC C compilers * * Some of the code here was originally in fiddle.c, some was originally * in cesspool.c. The rest is a translation into C of syslib.i. * LICENSE TERMS Copyright (C) 1996 Eric S. Raymond Copyright (C) 2006 Alex Smith 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. */ #define ick_resume ick_popnext ICK_INT32 ick_mingle(ICK_INT16 r, ICK_INT16 s) { 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; } ICK_INT32 ick_iselect(ICK_INT32 r, ICK_INT32 s) { ICK_INT32 i = 1, t = 0; while (s) { if (s & i) { t |= r & i; s ^= i; i <<= 1; } else { s >>= 1; r >>= 1; } } return t; } ICK_INT16 ick_and16(ICK_INT16 n) { ICK_INT16 m; m = (n >> 1); if (n & 1) m |= 0x8000; return(m & n); } ICK_INT16 ick_or16(ICK_INT16 n) { ICK_INT16 m; m = (n >> 1); if (n & 1) m |= 0x8000; return(m | n); } ICK_INT32 ick_and32(ICK_INT32 n) { ICK_INT32 m; m = (n >> 1); if (n & 1) m |= 0x80000000; return(m & n); } ICK_INT32 ick_or32(ICK_INT32 n) { ICK_INT32 m; m = (n >> 1); if (n & 1) m |= 0x80000000; return(m | n); } ICK_INT16 ick_xor16(ICK_INT16 n) { ICK_INT16 m; m = (n >> 1); if (n & 1) m |= 0x8000; return(m ^ n); } ICK_INT32 ick_xor32(ICK_INT32 n) { ICK_INT32 m; m = (n >> 1); if (n & 1) m |= 0x80000000; return(m ^ n); } ICK_INT8 ick_nextindex = 0; ICK_INT16 ick_next[16]; void ick_pushnext(ICK_INT16 n) { ick_next[ick_nextindex++] = n; } ICK_INT16 ick_popnext(ICK_INT8 n) { if (ick_nextindex < n) { ick_nextindex = 0; return (ICK_INT16)-1; } else ick_nextindex -= n; return(ick_next[ick_nextindex]); } /* It's hard to do randomization on a PIC. */ ICK_INT1 ick_roll(ICK_INT8 n) { return n>50; } /* Syslib, implemented in C to save ROM space. */ #if defined(ONESPOT1)&&defined(ONESPOT2)&&defined(TWOSPOT1) void syslibopt1050() { ONESPOT2=0; if(ONESPOT1) ONESPOT2=TWOSPOT1/ONESPOT1; } void syslibopt1520() { TWOSPOT1=((ICK_INT32)ONESPOT1<<16)|ONESPOT2; } #endif /* .1 .2 :1 */ #if defined(TWOSPOT1)&&defined(TWOSPOT2)&&defined(TWOSPOT3) void syslibopt1550() { TWOSPOT3=0; if(TWOSPOT2) TWOSPOT3=TWOSPOT1/TWOSPOT2; } void syslipopt1500() { TWOSPOT3=TWOSPOT2+TWOSPOT1; } void syslibopt1510() { TWOSPOT3=TWOSPOT1-TWOSPOT2; } void syslibopt1530() { TWOSPOT3=TWOSPOT1*TWOSPOT2; } void syslibopt1540() { TWOSPOT3=0; if(TWOSPOT2) TWOSPOT3=TWOSPOT1/TWOSPOT2; } #ifdef TWOSPOT4 void syslibopt1509() { TWOSPOT3=TWOSPOT2+TWOSPOT1; TWOSPOT4=1; if(TWOSPOT30xffffffff/TWOSPOT2) TWOSPOT4=2; TWOSPOT3=TWOSPOT1*TWOSPOT2; } #endif /* :4 */ #endif /* :1 :2 :3 */ #if defined(ONESPOT1)&&defined(ONESPOT2)&&defined(ONESPOT3) void syslipopt1000() { ONESPOT3=ONESPOT2+ONESPOT1; } void syslibopt1010() { ONESPOT3=ONESPOT1-ONESPOT2; } void syslibopt1030() { ONESPOT3=ONESPOT1*ONESPOT2; } void syslibopt1040() { ONESPOT3=0; if(ONESPOT2) ONESPOT3=ONESPOT1/ONESPOT2; } #ifdef ONESPOT4 void syslibopt1009() { ONESPOT3=ONESPOT2+ONESPOT1; ONESPOT4=1; if(ONESPOT30xffff/ONESPOT2) ONESPOT4=2; ONESPOT3=ONESPOT1*ONESPOT2; } #endif /* .4 */ #endif /* .1 .2 .3 */ #ifdef ONESPOT1 void syslibopt1020() { ONESPOT1++; } #endif intercal-0.29/src/dekludge.c0000644000175000017500000005252411443403272015650 0ustar brooniebroonie/**************************************************************************** Name dekludge.c -- C-INTERCAL expression and flow optimizers DESCRIPTION This file contains optimizations used by the C-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 "config.h" #include #include #include #include "sizes.h" #include "ick.h" #include "parser.h" #include "fiddle.h" #include "ick_lose.h" #include "feh.h" extern int emitlineno; /* AIS: From feh2.c */ /* AIS: The following macro produces optimization debug data. I added all occurences of it in this source file. It also keeps track of whether optimizations have taken place. */ #define OPTING(x) if(optdebug == 2) {\ explexpr(optdebugnode,stderr);\ putc('\n',stderr); } \ if(optdebug == 3) {\ prexpr(optdebugnode,stderr,0);\ putc('\n',stderr); } \ if(optdebug) fprintf(stderr,"[%s]",#x);\ if(optdebug >= 2) putc('\n',stderr);\ opted = 1; void checknodeactbits(node *np); /* AIS: This prototype needed early */ extern void prexpr(node *np, FILE* fp, int freenode); /* AIS */ /* By AIS. This function looks remarkably like a C++ copy-constructor to me, just with extra arrows in. The annotations here show that nulls are allowed when called recursively, but not otherwise. */ /*@-incondefs@*/ /*@null@*/ node *nodecopy(/*@null@*/ const node* n) /*@=incondefs@*/ { node* np; if(!n) return 0; np = cons(n->opcode, nodecopy(n->lval), nodecopy(n->rval)); np->constant = n->constant; np->optdata = n->optdata; np->width = n->width; return np; } /* This function by AIS. Compares expressions. In C++, I'd call this node::operator== . */ bool nodessame(/*@observer@*/ const node* n1, /*@observer@*/ const node* n2) { if(!n1) return !n2; if(!n2) return 0; if(n1->opcode!=n2->opcode) return (((n1->opcode == MESH && n2->opcode == MESH32) || (n1->opcode == MESH32 && n2->opcode == MESH)) && n1->constant == n2->constant); if(!nodessame(n1->lval,n2->lval)) return 0; if(!nodessame(n1->rval,n2->rval)) return 0; switch(n1->opcode) { case ick_ONESPOT: case ick_TWOSPOT: case ick_HYBRID: case ick_TAIL: case MESH: case MESH32: return n1->constant == n2->constant; case AND: case OR: case XOR: return n1->width == n2->width; default: return true; } } /* AIS: Checks if an abstention could affect a tuple. */ static int abstainmatch(int npconstant, int tptype) { if(npconstant == tptype) return 1; if(npconstant == ABSTAIN) if(tptype == FROM || tptype == MANYFROM || tptype == DISABLE) return 1; if(npconstant == REINSTATE) if(tptype == ENABLE) return 1; if(npconstant == GETS) if(tptype == RESIZE) return 1; if(npconstant == UNKNOWN) /* JH */ if(tptype == SPLATTERED) return 1; return 0; } /************************************************************************* * * AIS: Flow optimizer. (I wrote the whole of optimizef.) * * This analyses the flow of the program, checking to see which lines can * have their guards omitted, which lines can be omitted altogether, which * variables can never be ignored, etc. The degenerator lower down can take * this information into account, producing faster and shorter source code. * In an ideal world, we'd end up with the produced INTERCAL looking like * proper C code, but somehow I think that's unlikely to happen. * At the moment, it just checks for unused !ick_abstained[] guards on * statements and removes them (possibly removing comments altogether). * This is minor, but should clear up degenerated code substantially. * It also allows the code for gets to replace ick_assign() with the faster = * in cases where this doesn't affect the behaviour of the program. * See the function itself for what I did to NEXT. * *************************************************************************/ void optimizef(void) { tuple* tp, *tpa, *tpb; atom* op; node* np; if(!flowoptimize) ick_lose(IE778, iyylineno, (const char *) NULL); for (tp = tuples; tp < tuples + ick_lineno; tp++) tp->abstainable = 0; /* abstainable holds whether a line's abstention status can change */ for (op = oblist; op != NULL && op < obdex; op++) op->ignorable = 0; /* ignorable holds whether a variable's ignorance status can change */ for (tp = tuples; tp < tuples + ick_lineno; tp++) { /* allow for warnings to be generated during flow optimisations */ /* AIS: I marked tuples as only deliberately, so that it produced warnings when aliased in an unsafe way. However, tuples isn't realloced during optimisation, so we can safely ignore the warning for it produced here. */ /*@-onlytrans@*/ optuple = tp; /*@=onlytrans@*/ if(tp->maybe) tp->abstainable = true; if(tp->exechance < 0) tp->initabstain = true; if(tp->exechance != 100 && tp->exechance != -100) tp->abstainable = true; if(tp->onceagainflag != onceagain_NORMAL) tp->abstainable = true; if(tp->type == ABSTAIN || tp->type == FROM) { tpa = tp->u.target - 1 + tuples; if(tpa->exechance >= 0) tpa->abstainable = true; } if(tp->type == REINSTATE) { tpa = tp->u.target - 1 + tuples; if(tpa->exechance < 0) tpa->abstainable = true; } if(tp->type == DISABLE || tp->type == MANYFROM) { for (tpa = tuples; tpa < tuples + ick_lineno; tpa++) { np = tp->u.node; if(tp->type == MANYFROM) np = np->rval; for(; np; np = np -> rval) if(abstainmatch((int)np->constant, (int)tpa->type)) if(tpa->exechance >= 0) tpa->abstainable = true; } } if(tp->type == ENABLE) { for (tpa = tuples; tpa < tuples + ick_lineno; tpa++) { np = tp->u.node; for(; np; np = np -> rval) if(abstainmatch((int)np->constant, (int)tpa->type)) if(tpa->exechance < 0) tpa->abstainable = true; } } if(tp->type == GETS && ick_Base == 2 && !opoverused) checknodeactbits(tp->u.node->rval); /* If optdata shows that the value must always fit in the variable, and the variable cannot be ignored, ick_assign can be replaced by the cheaper =. */ if(tp->type == IGNORE) { for (np = tp->u.node; np; np = np->rval) { for (op = oblist; op != NULL && op < obdex; op++) { if(op->type == np->opcode && (unsigned long)op->intindex == np->constant) op->ignorable = 1; } } } /* REMEMBERING variables has no effect on this code, because all variables are initially remembered anyway, and so an IGNORE would be needed (and caught above) to have an effect. */ } /* There are some flow idioms that maybe should be optimized. The most common is the NEXTing idiom for if(), which looks like this: DO (1) NEXT block 2 escape via NEXTING or COMEFROM (1) DO (2) NEXT DO FORGET #1 block 1 and elsewhere in the program: (2) DO RESUME <1-or-2-condition> Recognizing this idiom is quite difficult because there are a number of problems and common variations. First, the FORGET might be placed elsewhere, or replaced with a higher FORGET later or a higher RESUME later. If there is, in fact, a RESUME #1 as the ick_next NEXT-control statement, the idiom won't quite work properly. So to handle this, we need to push the original return address on the NEXT stack if block 1 is taken, unless the ick_next statement is a FORGET #1. Second, there may be abstentions or COME FROMs messing with control flow in the area. The flow optimizer ought to be able to detect this and not optimize the statement if true. (This means that a program which uses gerund abstention on NEXTING or RESUMING, or that uses computed COME FROM, will probably not benefit from this optimization). Third, how should a <1-or-2-condition> be detected? Throughout syslib, the most common condition to use is .5, which isn't inherently 1 or 2. The way round this seems to be to detect a <1-or-2-assignment> as the previous statement, again with checks for COME FROM and abstentions. (I treat MAYBE as a sort of abstention, albeit a temporally undecided one.) So ignorance of the relevant variable needs to be checked for also. The checks are done partly in optimizef() and partly in emit(). */ if(compucomesused||ick_Base!=2||opoverused) return; np = (node*) NULL; for (tp = tuples; tp < tuples + ick_lineno; tp++) { if(tp->type == GETS) { /* if(tp->u.node->rval->opcode == C_AND1ADD1 || tp->u.node->rval->opcode == C_2SUBAND1 || ((tp->u.node->rval->opcode == C_1PLUS || tp->u.node->rval->opcode == C_2MINUS) && tp->u.node->rval->rval->optdata == 1)) //debug for now */ if(0) { /* This won't catch all <1-or-2-expressions>, but will get most of them. */ if(tp->u.node->lval->opcode != SUB) np = tp->u.node->lval; } else if(np != NULL && nodessame(np, tp->u.node->lval)) np = (node*) NULL; if(tp->nextable) np = (node*) NULL; if(tp->maybe||tp->abstainable) np = (node*) NULL; if(tp->ncomefrom&&multithread) np = (node*) NULL; if(np) { /* IGNORING np might prevent it getting its <1-or-2-value>. */ atom* op2; int ignorable = 1; for(op2 = oblist; op2 != NULL && op2 < obdex; op2++) { if(op2->type == np->opcode && (unsigned long)op2->intindex == np->constant) { ignorable &= op2->ignorable; } } if(ignorable) np = (node*) NULL; } /* np will only have a nonnull value if it's a variable that must be set to a <1-or-2-value> to reach line tp. Regardless of whether maybes have been parsed or not, either maybe or abstainable or both will be 1 on a MAYBE line. The last check is a precaution against MAYBE COME FROM sneakily modifying a variable (although I think it's unlikely that anyone would deliberately try to fool -f like this, it is INTERCAL after all!) */ } if(tp->type == COME_FROM || tp->type == COMPUCOME) np = (node*) NULL; if(tp->type == NEXT) { tpa = tuples + tp->nexttarget - 1; if(tpa->type == NEXT && !tp->abstainable && !tpa->abstainable && !tp->ncomefrom && !tpa->ncomefrom) { tpb = tuples + tpa->nexttarget - 1; if(tpb->type == RESUME && (/*(tpb->u.node->opcode == C_AND1ADD1 || tpb->u.node->opcode == C_2SUBAND1 || ((tpb->u.node->opcode == C_1PLUS || tpb->u.node->opcode == C_2MINUS) && tpb->u.node->rval->optdata == 1)) ||*/ (np != NULL && nodessame(tpb->u.node,np))) && !tpb->abstainable) /* No COMING FROM a nonabstainable RESUME line! */ { tp->optversion = true; free(tp->u.node); tp->u.node = nodecopy(tpb->u.node); /* If tp->u.node is 2, then the statement should translate to a no-op (NEXT...NEXT...RESUME #2). However, if tp->u.node is 1, the statement should translate to a NEXT to the line after the one it's aiming for. As it's aiming for a NEXT, the solution is to NEXT to the return label of the NEXT it's aiming for. This won't trigger any COME FROMs or ONCE/AGAIN flags, or even MAYBEs, on the commands missed out, so the code has checked that they aren't there. */ } } np = (node*) NULL; } } /*@-nullstate@*/ /* no tuples->u.node can't be null */ } /*@=nullstate@*/ /************************************************************************* * * Expression optimizer. * * It's not a very good optimizer, is it? * * AIS: All free'd pointers set to NULL, to help trace memory problems. * The optimizer can now recognize the majority of syslib's idioms. * The optimizer will make multiple passes. Although I am now happy * with the quality of this optimizer, I'll keep the paragraph above * this one for history's sake. The optimizing functions return 1 * if any optimizations were made, apart from optimize itself, which * is void. * **************************************************************************/ extern int optimize_pass1(node *np); /* Read from idiotism.c */ static void checkforintercaloperators(const node *np); static void checkW534(const node *np); node* optdebugnode; /* This function by AIS */ void optimize(node *np) { int optflag; if(opoverused) return; /* what chance do we have of optimizing this? */ if(ick_Base==2) { checknodeactbits(np); checkW534(np); /* This must be done before optimization, and depends on checknodeactbits. */ } if(optdebug == 1) explexpr(np,stderr); if(optdebug == 1) fprintf(stderr," becomes "); if(optdebug >= 2) optdebugnode = np; if(ick_Base==2) (void) optimize_pass1(np); /* Optimize idioms; from idiotism.oil */ if(ick_Base!=2) { if(optdebug && optdebug != 3) explexpr(np,stderr); if(optdebug == 3) prexpr(np,stderr,0); if(optdebug) fprintf(stderr,"\n"); if(optdebug >= 2) fprintf(stderr,"-----\n"); return; } do { optflag = optimize_pass1(np); } while(optflag); /* Keep optimizing until no optimizations are found */ if(optdebug && optdebug != 3) explexpr(np,stderr); if(optdebug == 3) prexpr(np,stderr,0); if(optdebug) fprintf(stderr,"\n"); if(optdebug >= 2) fprintf(stderr,"-----\n"); checkforintercaloperators(np); if(optuple->type == RESUME && !np->optdata) optuple->warn622 = true; } /* By AIS. This relies on free'd pointers being NULLed. The annotations are basically trying to describe how the function operates. */ void nodefree(/*@keep@*/ /*@null@*/ node *np) { if(!np) return; /*@-mustfreeonly@*/ if(np->nextslat) return; /* don't free, has oo data */ if(np==prevslat) return; /* likewise */ /*@=mustfreeonly@*/ /*@-keeptrans@*/ nodefree(np->lval); nodefree(np->rval); free(np); /*@=keeptrans@*/ } /* By AIS. This checks W534. */ static void checkW534(const node *np) { if(!np) return; if(np->opcode == AND || np->opcode == OR || np->opcode == XOR) { if(np->rval->opcode == SELECT && np->rval->rval->width == 32 && !(np->rval->rval->optdata&0xffff0000lu)) { /* This looks suspicious, in that C-INTERCAL will do an op32, but INTERCAL-72 would have done an op16. */ optuple->warn534=true; } } checkW534(np->lval); checkW534(np->rval); } /* By AIS. This checks W018. */ static void checkforintercaloperators(const node *np) { if(!np) return; switch(np->opcode) { /* This only comes up in binary. */ case AND: case OR: case XOR: case MINGLE: case SELECT: optuple->warn018 = true; break; default: checkforintercaloperators(np->lval); checkforintercaloperators(np->rval); return; } } /* By AIS (with a few code fragments copied from elsewhere in this file) This generates the values of c used by the OIL idiom file idiotism.oil. */ void checknodeactbits(node *np) { int temp; if (np == (node *)NULL) return; else if (np->lval != (node *)NULL) checknodeactbits(np->lval); if (np->rval != (node *)NULL) checknodeactbits(np->rval); switch (np->opcode) { case MINGLE: /*@-nullderef@*/ /* mingle has two nonnull arguments */ if(np->lval->optdata & 0xffff0000LU) optuple->warn276 = true; if(np->rval->optdata & 0xffff0000LU) optuple->warn276 = true; np->optdata = ick_mingle((unsigned)(np->lval->optdata & 0xffff), (unsigned)(np->rval->optdata & 0xffff)); /*@=nullderef@*/ /* The bitmask is needed because the output of ~ might always be 16-bit at runtime, but appear 32-bit at compile-time. But this is somewhat suspicious, so we can at least give a warning (W276) if -l is used. */ break; case SELECT: /* The result could be the selected optdata, or have a 1 anywhere to the right of a 1 in the resulting selection if there are 0s in rval where there could have been 1s */ /*@-nullderef@*/ np->optdata = ick_iselect((unsigned)np->lval->optdata, (unsigned)np->rval->optdata); /*@=nullderef@*/ temp=32; while(temp--) np->optdata|=(np->optdata>>1); /* fill in gaps in optdata */ break; case AND: if(np->width==16) np->optdata = ick_and16((unsigned)np->rval->optdata); else np->optdata = ick_and32((unsigned)np->rval->optdata); break; case OR: case XOR: if(np->width==16) np->optdata = ick_or16((unsigned)np->rval->optdata); else np->optdata = ick_or32((unsigned)np->rval->optdata); /* This is or in both cases. */ break; case FIN: case WHIRL: case WHIRL2: case WHIRL3: case WHIRL4: case WHIRL5: /* We must be in binary to reach this point, so: */ ick_lose(IE997, emitlineno, (const char*) NULL); /*@-unreachable@*/ break; /*@=unreachable@*/ case MESH: case MESH32: np->optdata = np->constant; /* It's trivial to tell which bits can be nonzero! */ break; case ick_ONESPOT: case ick_TWOSPOT: case ick_TAIL: case ick_HYBRID: case SUB: np->optdata = np->width == 16 ? 0xffffLU : 0xffffffffLU; break; /* cases from here down are generated by optimize_pass1 */ case C_AND: /*@-nullderef@*/ np->optdata = np->lval->optdata & np->rval->optdata; /*@=nullderef@*/ break; case C_OR: case C_XOR: /*@-nullderef@*/ np->optdata = np->lval->optdata | np->rval->optdata; /*@=nullderef@*/ /* bitwise-or is correct in both cases */ break; case C_NOT: np->optdata = np->width == 16 ? 0xffffLU : 0xffffffffLU; break; case C_A: np->optdata = 0xffffffffLU; break; case C_NOTEQUAL: case C_ISEQUAL: case C_LOGICALNOT: case C_LOGICALAND: case C_LOGICALOR: case C_GREATER: case C_LESS: np->optdata = 1; /* this is a logical function */ break; case C_RSHIFTBY: /*@-nullderef@*/ if(np->rval->opcode == MESH || np->rval->opcode == MESH32) np->optdata = np->lval->optdata >> np->rval->constant; else np->optdata = (np->width == 16 ? 0xffffLU : 0xffffffffLU); /*@=nullderef@*/ /* Play safe if the RHS isn't a constant */ break; case C_LSHIFTBY: /*@-nullderef@*/ if(np->rval->opcode == MESH || np->rval->opcode == MESH32) np->optdata = np->lval->optdata << np->rval->constant; else np->optdata = (np->width == 16 ? 0xffffLU : 0xffffffffLU); /*@=nullderef@*/ /* Play safe if the RHS isn't a constant */ break; case C_PLUS: /* A bit could be set if it's set in either of the numbers, or if it's set by a carry; so OR together the two numbers and their sum. */ /*@-nullderef@*/ np->optdata = np->lval->optdata | np->rval->optdata | (np->lval->optdata + np->rval->optdata); /*@=nullderef@*/ break; case C_MINUS: case C_DIVIDEBY: /* The optimizer shouldn't be able to generate negative answers or divisions by 0, so just fill in all bits from lval rightwards */ /*@-nullderef@*/ np->optdata = np->lval->optdata; np->optdata |= np->optdata >> 1; np->optdata |= np->optdata >> 2; np->optdata |= np->optdata >> 4; np->optdata |= np->optdata >> 8; np->optdata |= np->optdata >> 16; /*@=nullderef@*/ break; case C_MODULUS: /* The answer must be smaller than both inputs, but we can't tell anything else */ /*@-nullderef@*/ np->optdata = np->lval->optdata; if(np->rval->optdata < np->optdata) np->optdata = np->rval->optdata; np->optdata |= np->optdata >> 1; np->optdata |= np->optdata >> 2; np->optdata |= np->optdata >> 4; np->optdata |= np->optdata >> 8; np->optdata |= np->optdata >> 16; /*@=nullderef@*/ break; case C_TIMES: /* Convolve one set of active bits with the other, ORadding the results */ np->optdata=0; temp=32; /*@-nullderef@*/ /*@-shiftnegative@*/ while(temp--) if(np->lval->optdata & (1LU << temp)) np->optdata = np->optdata | (np->rval->optdata << temp) | ((np->rval->optdata << temp) + np->optdata); /*@=nullderef@*/ /*@=shiftnegative@*/ break; case GETS: /* Of course, this doesn't return a value. So this uses the default code just below it, which is why it doesn't end in break;. This has its own case so that W276 can be given on an assignment. */ /*@-nullderef@*/ if(np->lval->optdata == 0xffff && np->rval->optdata & 0xffff0000lu) optuple->warn276 = true; /*@=nullderef@*/ /*@fallthrough@*/ case UNKNOWNOP: default: /*@-nullderef@*/ if(np->opcode == BY && !np->lval->optdata) optuple->warn239 = true; /*@=nullderef@*/ np->optdata = (np->width == 16 ? 0xffffLU : 0xffffffffLU); /* Some values of opcode are used as placeholders, to save more than 1 piece of information in a node. The optdata for these is probably irrelevant, but just in case, we mark all possible bits as active. */ break; } } intercal-0.29/src/ick-wrap.c0000644000175000017500000000347611435477314015614 0ustar brooniebroonie$L /* $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 $M #include "fiddle.h" #include "abcess.h" #include "ick_lose.h" $K #ifdef ICK_EC #include "ick_ec.h" void ick_main(void); #endif #define ICKABSTAINED(d) ick_abstained[d] #define ICKSTASH(a,b,c,d) ick_stash(a, b, c+b, d) #define ICKRETRIEVE(a,b,c,d,e) ick_retrieve(a+b, c, b, d[b], e) #define ICKIGNORE(a,b,c) a[b] extern int ick_printflow; int ick_lineno; jmp_buf ick_cjb; int ick_ccfc; long ick_skipto=0; $O char* ick_globalargv0; int ick_oldabstain; int ick_abstained[$B]$C; $D $E $P int main(int argc, char *argv[]) { #ifndef YUK ick_parseargs(argc,argv); #endif ick_skipto = 0; ick_next = calloc(80, sizeof *ick_next); #ifdef ICK_EC ick_next_jmpbufs = malloc(81 * sizeof *ick_next_jmpbufs); #endif $N ick_globalargv0=argv[0]; #ifdef YUK yuklines = $J; yukcommands = $B; globalargv = argv; globalargc = argc; #endif /* set seed for random error generation */ #ifdef USG srand48(time(0) + getpid()); #else srand(time(0)); #endif /* UNIX */ #if MULTITHREAD == 1 ickmtinit(); #endif /* set up stash storage */ ick_stashinit(); $F #ifdef ICK_EC ick_runstartups(); ick_next(0); } ICK_EC_FUNC_START(ick_main) { ick_linelabelnosp(0); #endif /* degenerated code */ ick_restart: top: switch((int)ick_skipto) { case 0: $G default: ick_lose(IE129, 0, (const char *)0); } #ifdef YUK if(yukloop) goto ick_restart; #endif ick_lose(IE633, $J, (const char *)0); $H #ifndef ICK_EC return 0; #else return; #endif } #ifdef ICK_EC ICK_EC_FUNC_END #endif $Q /* Generated code for $A.i ends here */ intercal-0.29/src/clc-cset.c0000644000175000017500000003471711443403052015561 0ustar brooniebroonie/***************************************************************************** NAME clc-cset.c -- CLC-INTERCAL character set support for C-INTERCAL LICENSE TERMS Copyright (C) 2007 Alex Smith 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. ***************************************************************************/ /* The input is read from files such as latin1.bin and ebcdic.bin. These contain three lines of text data that specify the length of the character set (number of characters in each shift state), the number of shift states, and the bit order of the input. The bit order can either be 8 characters long (msb down to lsb) or 16 (the ick_first byte in a pair, followed by the second); each bit of the input is transferred to the corresponding bit in a binary table that follows (a for the lsb, b for the second least significant bit, up to l for the 12th least significant bit; at most 12 significant bits are allowed), or x for a don't care on the bit. The table that follows is the relevant character codes in Latin-1 (which is used as the interconversion language); if shift states are used, they're represented by character codes 1, 2, 3, etc.. Invalid characters are represented by character code 0, and changed to nulls on output. The order of the bytes is 'Latin-1 for this set's char 0 in shift state 1', 'Latin-1 for this set's char 0 in shift state 2', ..., 'Latin-1 for this set's char 1 in shift state 1', and so on. Note that as the character set feature is designed to mirror CLC-INTERCAL's, I've sprinkled a bit of idiomatic Perl throughout the code. This is quite rare, though, as it has to be also legal in C. */ #include #include #include #include "uncommon.h" #define NCSETRECENT 8 /* Sometimes we want to link the character set files to the program * rather than reading them from disk; in this case, these extern * variables will be set non-null by object files invented * specifically for the purpose. */ extern /*@null@*/ const char* ick_clc_cset_atari; extern /*@null@*/ const char* ick_clc_cset_baudot; extern /*@null@*/ const char* ick_clc_cset_ebcdic; extern /*@null@*/ const char* ick_clc_cset_latin1; static /*@null@*/ const char* ick_clc_cset_ptr=0; /* Fake that we're reading hardcoded characters from a file. This * method of doing it is obviously not thread-safe. */ static int ick_clc_cset_hardcoderead(FILE* ignored) { /*@-noeffect@*/ (void) ignored; /*@=noeffect@*/ return (int)*ick_clc_cset_ptr++; } struct cset { unsigned char set[4096]; /* allow up to 12 bits of data+shifts */ unsigned short setlen; int shifts; char setname[9]; /* 8.3 filenames are enforced! */ char bitorder[16]; int nbytes; }; /* In particular, this initialises the setnames to the null string, * and clears nbytes. Both of these are used to determine whether a * cset is valid or not. */ /*@-initallelements@*/ /*@-type@*/ static struct cset ick_cset_recent[NCSETRECENT]={{{0},0,0,{0},{0},0}}; /*@=initallelements@*/ /*@=type@*/ static int ick_csetow=0; /* which cset to overwrite ick_next */ /* For help finding files */ /*@observer@*/ extern char* ick_globalargv0; /*@observer@*/ extern const char* ick_datadir; /*@-mustfreefresh@*/ /* because Splint doesn't understand how findandfopen works */ static void ick_clc_cset_load(/*@unique@*/ struct cset* cs, /*@unique@*/ const char* fname) { FILE* in; char buf[13]; /* enough for an 8.3 filename */ int i,j,c; int (*ipf)(FILE*); /* Avoid buffer-overflow attacks. */ if(strlen(fname)>8) return; /* If ick_clc_cset_atari is non-null, then don't read from disk. */ if(ick_clc_cset_atari) { /* If the character sets have been hardcoded, only accept * hardcoded chararacter sets. */ ick_clc_cset_ptr=0; if(!strcmp(fname,"atari")) ick_clc_cset_ptr=ick_clc_cset_atari; if(!strcmp(fname,"baudot")) ick_clc_cset_ptr=ick_clc_cset_baudot; if(!strcmp(fname,"ebcdic")) ick_clc_cset_ptr=ick_clc_cset_ebcdic; if(!strcmp(fname,"latin1")) ick_clc_cset_ptr=ick_clc_cset_latin1; if(!ick_clc_cset_ptr) return; /* not a hardcoded charset */ in=(FILE*)0; ipf=ick_clc_cset_hardcoderead; } else { /* We already checked above that this isn't a buffer overflow. */ /*@-bufferoverflowhigh@*/ sprintf(buf,"%s.bin",fname); /*@=bufferoverflowhigh@*/ if(!(in=ick_findandfopen(buf,ick_datadir,"rb",ick_globalargv0))) return; ipf=fgetc; } /* First row: setlen */ cs->setlen=0; do { /* The input is definitely in ASCII, even if the C program isn't, which is why numeric codes are used. */ /* Here, ipf allows NULL input iff in is actually NULL; this situation is impossible to explain with an annotation, so instead just disable the warning. */ /*@-nullpass@*/ c=ipf(in); /*@=nullpass@*/ if(c==EOF) {if(in) (void)fclose(in); return;} if(c<48||c>57) break; cs->setlen*=10; cs->setlen+=c-48; } while(1); if(c!=10) {if(in) (void)fclose(in); return;} /* Second row: shifts. This can be from 1 to 9. */ /*@-nullpass@*/ c=ipf(in); /*@=nullpass@*/ if(c<49||c>57) {if(in) (void)fclose(in); return;} cs->shifts=c-48; /*@-nullpass@*/ if(ipf(in)!=10) {if(in) (void)fclose(in); return;} /*@=nullpass@*/ /* Third row: byte order. */ i=0; /*@-nullpass@*/ while(((c=ipf(in)))>96&&i<16) cs->bitorder[i++]=(char)c; /*@=nullpass@*/ /* Sanity check; that it is a whole number of bytes, that the input * format is correct, and that there are at most 4096 bytes of data * total. */ if(c!=10||i%8||!i||cs->setlen*cs->shifts>4096) return; /* i/8 is now the number of bytes, but don't set that yet in case * there's an error later. */ /* Rest of file: the bytes themselves. */ j=0; /*@-nullpass@*/ while(jsetlen*cs->shifts) if((cs->set[j++]=(unsigned char)(c=ipf(in))),c==EOF && in != NULL) {if(in) (void)fclose(in); return;} /*@=nullpass@*/ if(in) (void) fclose(in); /* Now set the name and number of bytes, indicating a successful * load. */ cs->nbytes=i/8; strcpy(cs->setname,fname); } /*@=mustfreefresh@*/ /* Helper function for fixing bit order in output. */ static void ick_bitencout(char** pop, const struct cset* co, unsigned short val, int padstyle) { unsigned short outword=0; int i=co->nbytes*8; /*@-shiftnegative@*/ /* i can't go above it's initial value here */ while(i--) if(co->bitorder[i]>'l') { if((padstyle==1&&(i==1||i==9) && !(outword&(1<<(co->nbytes*8-i)))) || (padstyle==2&&(rand()%2||!outword))) outword |= 1<<(co->nbytes*8-i-1); } /* Copy the appropriate bit from val to outword. */ else outword |= (unsigned short)((val>>(co->bitorder[i]-'a'))&1) << (co->nbytes*8-i-1); /*@=shiftnegative@*/ if(co->nbytes==2) *(*pop)++=(char)(outword/256); *(*pop)++=(char)(outword%256); } /* padstyle is 0 to pad with zeros, 1 to pad to make the output * printable characters, or 2 to pad with garbage, avoiding 0s. * Return value is the number of characters in the output string, * which may contain embedded NULs if the input contained invalid * characters. Returns -1 on error. The caller is responsible for * making sure that out is big enough, but as a check, no more than * outsize-1 characters and a NUL will be written to out. The code is * conservative about this; to be safe, make outsize six times as long * as the in is (including in's terminal NUL), plus 6. */ int ick_clc_cset_convert(const char* in, /*@partial@*/ char* out, const char* incset, const char* outcset, int padstyle, size_t outsize, /*@null@*/ FILE* errsto) { int ic=-1, oc=-1; int i; int ssi, sso; unsigned short tus, csi; const char* ip; char* op; struct cset *csri, *csro; int noconvwarn=0; int substwarn=0; /* First, see if we have a recently-used version of incset or outcset. */ i=NCSETRECENT; while(i--) { (void)(strcmp(incset,ick_cset_recent[i].setname) || (ic=i)); (void)(strcmp(outcset,ick_cset_recent[i].setname) || (oc=i)); } /* Find a blank entry to load on top of. */ if(ic==-1) for(i=NCSETRECENT;i--;) if(!ick_cset_recent[i].nbytes) ic=i; if(oc==-1) for(i=NCSETRECENT;i--;) if(!ick_cset_recent[i].nbytes&&i!=ic) oc=i; /* Failing that, find any entry to load on top of. */ (void)(ic==-1 && (ick_cset_recent[ic=ick_csetow++].nbytes=0)); if(ick_csetow==ic) ick_csetow++; ick_csetow%=NCSETRECENT; (void)(oc==-1 && (ick_cset_recent[oc=ick_csetow++].nbytes=0)); ick_csetow%=NCSETRECENT; /* If the character set hasn't been loaded, load it now. */ ick_cset_recent[ic].nbytes || (ick_clc_cset_load(ick_cset_recent+ic,incset),0); ick_cset_recent[oc].nbytes || (ick_clc_cset_load(ick_cset_recent+oc,outcset),0); csri=ick_cset_recent+ic; csro=ick_cset_recent+oc; /* If a character set failed to load, bail out. */ if(!csri->nbytes) { if(errsto) fprintf(errsto,"Error: Nonexistent input character set.\n"); return -1; } if(!csro->nbytes) { if(errsto) fprintf(errsto,"Error: Nonexistent output character set.\n"); return -1; } /* There is no initial shift state. */ ssi=sso=0; csri->shifts==1 && (ssi=1); csro->shifts==1 && (sso=1); ip=in; op=out; while(*ip != '\0' && (size_t)(op-out)nbytes==2) { tus*=256; tus+=(unsigned short)(unsigned char)*ip++; } i=csri->nbytes*8; csi=0; while(i--) { if(csri->bitorder[i]>'l') continue; /* Copy the appropriate bit from tus to csi. */ /*@-shiftnegative@*/ csi |= (unsigned short)((tus>>(csri->nbytes*8-i-1))&1) << (csri->bitorder[i]-'a'); /*@=shiftnegative@*/ } if(csi>csri->setlen) { ick_bitencout(&op,csro,0,padstyle); /* not in the charset */ if(!noconvwarn && errsto != NULL) fprintf(errsto,"Warning: some characters could not be translated," " they were replaced with NUL.\n"); noconvwarn=1; } else { /* The more interesting case. */ csi*=csri->shifts; if(!ssi) { /* We're at the start of a shift-stated string, but not actually in any shift state. There is no general solution here, so use one that works for Baudot: starting in each state in turn, choose the option that takes the longest until it ends up not changing shift state, then perform one shift from that option. */ int sstesting, ssbestsf, ssrecord, j, k; sstesting=csri->shifts+1; ssbestsf=ssrecord=0; while(--sstesting) { k=sstesting; j=0; while(csri->set[csi+i-1] != (unsigned char)0 && (int)csri->set[csi+i-1]!=k && (int)csri->set[csi+i-1]<=csri->shifts) {k=(int)csri->set[csi+i-1]; j++;} if(ssbestsfset[csi]; /* we now have the Latin-1 conversion! */ if(tus>=1&&tus<=(unsigned short)csri->shifts&&csri->shifts>1) { /* That wasn't a character, but a shift command. */ ssi=(int)tus; continue; } /* Look for the character in the output's character * set. Preferably we want something in the current shift * state, but failing that, any character will do. */ spacenowtab: i=csro->shifts*csro->setlen; csi=10000; while(i--) (void)((unsigned short)csro->set[i]==tus && (csi==10000 || (int)csi%csro->shifts!=sso-1) && (csi=(unsigned short)i)); if(csi==10000&&tus==9 /* latin-1 tab */) { if(!substwarn && errsto != NULL) fprintf(errsto,"Warning: no tab in output character set," " space was used instead.\n"); substwarn=1; tus=32; /* latin-1 space */ goto spacenowtab; } if(csi==10000) { ick_bitencout(&op,csro,0,padstyle); /* not in the charset */ if(!noconvwarn && errsto != NULL) fprintf(errsto,"Warning: some characters could not be translated," " they were replaced with NUL.\n"); noconvwarn=1; } else if((int)(csi%csro->shifts)==(int)sso-1) /* in the right shift state already */ ick_bitencout(&op,csro,(unsigned short)(csi/csro->shifts),padstyle); else { int tempi; /* Generate shift codes. If sso isn't 0, generate from where * we are at the moment; if it is 0, generate worse-case * shifts by assuming we're in a shift state that can't shift * to the state we want directly, if possible. */ if(!sso) { int j=csro->shifts+1; while(--j>0) { if(j-1==(int)(csi%csro->shifts)) continue; i=(int)csro->setlen; while(i--) if((int)csro->set[i*csro->shifts+j-1]==csi%csro->shifts+1) {j=-j; break; /* there is one in this set */}; j=-j; if(j<0) break; } /* Pick the worst-case if we found one, or otherwise just * any state we aren't in at the moment. */ sso=(j<0?-j:(int)(csi%csro->shifts)); if(!sso) sso=csro->shifts; } /* Look for the shift code, if there is one. */ i=(int)csro->setlen; while(i--) if((int)csro->set[i*csro->shifts+sso-1]==csi%csro->shifts+1) break; tempi=i*csro->shifts+sso-1; if(i==-1) { int intershift=-1; /* That didn't work. Look for the shift code in some shift * state other than the one we're aiming for. */ retry: i=csro->setlen*csro->shifts; while(i--) if((int)csro->set[i]==csi%csro->shifts+1&& i%csro->shifts!=(int)(csi%csro->shifts)&& i%csro->shifts+1!=intershift) break; if(i==-1) return -1; /* no way to get into the right state */ intershift=i%csro->shifts+1; tempi=i; i=(int)csro->setlen; while(i--) if((int)csro->set[i*csro->shifts+sso-1]==intershift) break; if(i==-1) goto retry; /* try once more */ ick_bitencout(&op,csro,(unsigned short)i,padstyle); /* sso=intershift here but we're going to overwrite it * immediately anyway, so no point in the assignment */ } ick_bitencout(&op,csro,(unsigned short)(tempi/csro->shifts),padstyle); ick_bitencout(&op,csro,(unsigned short)(csi/csro->shifts),padstyle); sso=csi%csro->shifts+1; } } } *op='\0'; return op-out; } intercal-0.29/src/latin1.bin0000644000175000017500000000041711435477314015605 0ustar brooniebroonie256 1 hgfedcba   !"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]^_`abcdefghijklmnopqrstuvwxyz{|}~€‚ƒ„…†‡ˆ‰Š‹ŒŽ‘’“”•–—˜™š›œžŸ ¡¢£¤¥¦§¨©ª«¬­®¯°±²³´µ¶·¸¹º»¼½¾¿ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖ×ØÙÚÛÜÝÞßàáâãäåæçèéêëìíîïðñòóôõö÷øùúûüýþÿintercal-0.29/src/fiddle.c0000644000175000017500000002252411435477314015321 0ustar brooniebroonie/* * 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" #include "ick_lose.h" #include unsigned int ick_mingle(register unsigned int r, register unsigned int s) { if (ick_Base == 2) { if (r>0xffff || s>0xffff) ick_lose(IE533, ick_lineno, (const char *)NULL); 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 < ick_Small_digits ; i++) { result += fac * (s % ick_Base); s /= ick_Base; fac *= ick_Base; result += fac * (r % ick_Base); r /= ick_Base; fac *= ick_Base; } return result; } } unsigned int ick_iselect(register unsigned int r, register unsigned int s) { if (ick_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 = (unsigned)ick_Base - 1 ; j > 0 ; j--) { int i; fac = 1; for (i = 0; i < ick_Large_digits ; i++) { if ((s / fac) % ick_Base == j) { digit = (r / fac) % ick_Base; if (digit) result += ofac * (digit > j ? digit : j); ofac *= ick_Base; } fac *= ick_Base; } } return result; } } static unsigned int ick_whirl(unsigned int len, unsigned int p, unsigned int n) { unsigned int i, fac = 1, result = 0, d1, d2, dsave; d1 = n % ick_Base; dsave = d1; for (i = 1 ; i <= len ; i++) { d2 = d1; d1 = (i < len) ? (n /= ick_Base, n % ick_Base) : dsave; if (d1 <= p) result += fac * ((d2 < d1 || d2 > p) ? d1 : d2); else result += fac * ((d2 < d1 && d2 > p) ? d1 : d2); fac *= ick_Base; } return result; } unsigned int ick_and16(unsigned int n) { if (ick_Base == 2) { unsigned int m = (n >> 1); if (n & 1) m |= 0x8000; return(m & n); } else { return ick_whirl((unsigned)ick_Small_digits,0,n); } } unsigned int ick_or16(unsigned int n) { if (ick_Base == 2) { unsigned int m = (n >> 1); if (n & 1) m |= 0x8000; return(m | n); } else { return ick_whirl((unsigned)ick_Small_digits,(unsigned)ick_Base-1,n); } } unsigned int ick_whirl16(unsigned int p, unsigned int n) { return ick_whirl((unsigned)ick_Small_digits,p,n); } unsigned int ick_and32(unsigned int n) { if (ick_Base == 2) { unsigned int m = (n >> 1); if (n & 1) m |= 0x80000000; return(m & n); } else { return ick_whirl((unsigned)ick_Large_digits,0,n); } } unsigned int ick_or32(unsigned int n) { if (ick_Base == 2) { unsigned int m = (n >> 1); if (n & 1) m |= 0x80000000; return(m | n); } else { return ick_whirl((unsigned)ick_Large_digits,(unsigned)ick_Base-1,n); } } unsigned int ick_whirl32(unsigned int p, unsigned int n) { return ick_whirl((unsigned)ick_Large_digits,p,n); } static unsigned int ick_xor(unsigned int len, unsigned int n) { unsigned int i, fac = 1, result = 0, d1, d2, dsave; d1 = n % ick_Base; dsave = d1; for (i = 1 ; i <= len ; i++) { d2 = d1; d1 = (i < len) ? (n /= ick_Base, n % ick_Base) : dsave; result += fac * ((ick_Base + d1 - d2) % ick_Base); fac *= ick_Base; } return result; } unsigned int ick_xor16(unsigned int n) { if (ick_Base == 2) { unsigned int m = (n >> 1); if (n & 1) m |= 0x8000; return(m ^ n); } else { return ick_xor((unsigned)ick_Small_digits,n); } } unsigned int ick_xor32(unsigned int n) { if (ick_Base == 2) { unsigned int m = (n >> 1); if (n & 1) m |= 0x80000000; return(m ^ n); } else { return ick_xor((unsigned)ick_Large_digits,n); } } static unsigned int ick_fin(unsigned int len, unsigned int n) { unsigned int i, fac = 1, result = 0, d1, d2, dsave; d1 = n % ick_Base; dsave = d1; for (i = 1 ; i <= len ; i++) { d2 = d1; d1 = (i < len) ? (n /= ick_Base, n % ick_Base) : dsave; result += fac * ((d1 + d2) % ick_Base); fac *= ick_Base; } return result; } unsigned int ick_fin16(unsigned int n) { if (ick_Base == 2) { unsigned int m = (n >> 1); if (n & 1) m |= 0x8000; return(m ^ n); } else { return ick_fin((unsigned)ick_Small_digits,n); } } unsigned int ick_fin32(unsigned int n) { if (ick_Base == 2) { unsigned int m = (n >> 1); if (n & 1) m |= 0x80000000; return(m ^ n); } else { return ick_fin((unsigned)ick_Large_digits,n); } } /* AIS: Reversed operations, for operand overloading */ static unsigned int ick_rotleft16(unsigned int n) { return !!(n&0x8000)|((n&0x7FFF)<<1); } static unsigned int ick_rotleft32(unsigned int n) { return !!(n&0x80000000)|((n&0x7FFFFFFF)<<1); } /* For the time being, just work out the answer in binary, and test using the base-whatever operation. This means that there'll nearly always be a failure in reversing in bases other than 2. */ unsigned int ick_rev_or16(unsigned int n) { if(ick_or16(ick_rotleft16(ick_and16(n)))==n) return ick_rotleft16(ick_and16(n)); ick_lose(IE277, ick_lineno, (const char*) NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } unsigned int ick_rev_or32(unsigned int n) { if(ick_or32(ick_rotleft32(ick_and32(n)))==n) return ick_rotleft32(ick_and32(n)); ick_lose(IE277, ick_lineno, (const char*) NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } unsigned int ick_rev_and16(unsigned int n) { if(ick_and16(ick_rotleft16(ick_or16(n)))==n) return ick_rotleft16(ick_or16(n)); ick_lose(IE277, ick_lineno, (const char*) NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } unsigned int ick_rev_and32(unsigned int n) { if(ick_and32(ick_rotleft32(ick_or32(n)))==n) return ick_rotleft32(ick_or32(n)); ick_lose(IE277, ick_lineno, (const char*) NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } unsigned int ick_rev_xor16(unsigned int n) { unsigned int a=0, l=1, t=0; while(l<=0x4000) { if(n&l) t^=1; if(t) a+=l*2; l*=2; } if(ick_xor16(a)==n) return a; ick_lose(IE277, ick_lineno, (const char*) NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } unsigned int ick_rev_xor32(unsigned int n) { unsigned int a=0, l=1, t=0; while(l<=0x4000000) { if(n&l) t^=1; if(t) a+=l*2; l*=2; } if(ick_xor32(a)==n) return a; ick_lose(IE277, ick_lineno, (const char*) NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } unsigned int ick_rev_fin16(unsigned int n) { unsigned int a=0, l=1, t=0; while(l<=0x4000) { if(n&l) t^=1; if(t) a+=l*2; l*=2; } if(ick_fin16(a)==n) return a; ick_lose(IE277, ick_lineno, (const char*) NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } unsigned int ick_rev_fin32(unsigned int n) { unsigned int a=0, l=1, t=0; while(l<=0x4000000) { if(n&l) t^=1; if(t) a+=l*2; l*=2; } if(ick_fin32(a)==n) return a; ick_lose(IE277, ick_lineno, (const char*) NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } unsigned int ick_rev_whirl16(unsigned int p, unsigned int n) { /* Only reverse if all digits are the same. */ if(ick_whirl16(p,n)==n) return n; ick_lose(IE277, ick_lineno, (const char*) NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } unsigned int ick_rev_whirl32(unsigned int p, unsigned int n) { /* Only reverse if all digits are the same. */ if(ick_whirl32(p,n)==n) return n; ick_lose(IE277, ick_lineno, (const char*) NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } /* AIS: Some helper functions for the optimizer, only working in base 2 */ unsigned int ick_xselx(unsigned int x) { register unsigned int r=0; if(ick_Base != 2) ick_lose(IE778, ick_lineno, (const char*) NULL); while(x) {if(x&1) r=(r<<1)|1; x>>=1;} return r; } unsigned int ick_setbitcount(unsigned int x) { register unsigned int r=0; while(x) {if(x&1) r++; x>>=1;} return r; } unsigned int ick_smudgeright(unsigned int x) { x=x|(x>>1); x=x|(x>>2); x=x|(x>>4); x=x|(x>>8); x=x|(x>>18); return x; } unsigned int ick_smudgeleft(unsigned int x) { x=x|(x<<1); x=x|(x<<2); x=x|(x<<4); x=x|(x<<8); x=x|(x<<18); return x; } /* fiddle.c */ intercal-0.29/src/ick_ec.c0000644000175000017500000002541711443403052015276 0ustar brooniebroonie/***************************************************************************** NAME ick_ec.c -- external call support between C and C-INTERCAL LICENSE TERMS Copyright (C) 2008 Alex Smith 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. ***************************************************************************/ /* Implement the INTERCAL flow control operators in C, except for ABSTAIN and REINSTATE. Worryingly, this is freestanding-legal and needs no C headers other than setjmp.h and stdint.h. (The printfs are just for +printflow debug output and don't effect the code flow.) */ #define ICK_EC 1 #include "ick_lose.h" #include "config.h" #include "abcess.h" /* must come before ick_ec.h */ #include "ick_ec.h" #include /* Checkmode values, for reference: * 0: not using checkmode * 1: looking for a COME FROM or NEXT FROM, or COME FROM found * 2: looking for a label to NEXT to or goto * 3: NEXT FROM found * 4: no suitable target found * 5: do a resume(1) if this reaches ick_allecfuncs * 6: starting up, run your init code */ int ick_global_checkmode = 0; /* ick_global_linelabel's marked as volatile to avoid problems with optimisation of assignments to it near setjmps. */ unsigned long ick_global_linelabel; static int ick_forgetamount = 0; unsigned long ick_global_goto; void* ick_global_createdata; extern ick_overop* ick_oo_twospots; /* Do a CREATEd operator check and call. */ /*@maynotreturn@*/ uint32_t ick_dounop(char* unopstr, uint32_t arg1, uint32_t arg2, int emitlineno, unsigned long vi1, unsigned long vi2, unsigned long vi3, ick_type32 (*og1)(ick_type32), ick_type32 (*og2)(ick_type32), ick_type32 (*og3)(ick_type32), void (*os1)(ick_type32, void(*)()), void (*os2)(ick_type32, void(*)()), void (*os3)(ick_type32, void(*)()), /*@observer@*/ const char* errstr) { int st; uint32_t rv; st = ick_jicmatch(unopstr); if(st) { ick_createdata icd[3]; icd[0].width=16; icd[1].width=16; icd[2].width=16; icd[0].isarray=0; icd[1].isarray=0; icd[2].isarray=0; icd[0].varnumber=1601; icd[1].varnumber=1602; icd[2].varnumber=1603; icd[0].accessors.get=og1;icd[1].accessors.get=og2;icd[2].accessors.get=og3; icd[0].accessors.set=os1;icd[1].accessors.set=os2;icd[2].accessors.set=os3; icd[0].value=arg1; icd[1].value=arg2; icd[2].value=0; ick_stash(ick_TWOSPOT, vi1, ick_twospots+vi1, ick_oo_twospots); ick_stash(ick_TWOSPOT, vi2, ick_twospots+vi2, ick_oo_twospots); ick_stash(ick_TWOSPOT, vi3, ick_twospots+vi3, ick_oo_twospots); ick_oo_twospots[vi1]=icd[0].accessors; ick_oo_twospots[vi2]=icd[1].accessors; ick_oo_twospots[vi3]=icd[2].accessors; ick_global_createdata=icd; ick_dogoto(st, emitlineno, 1); rv = og3(ick_twospots[vi3]); ick_retrieve(ick_twospots+vi1, ick_TWOSPOT, vi1, ick_twoforget[vi1], ick_oo_twospots); ick_retrieve(ick_twospots+vi2, ick_TWOSPOT, vi2, ick_twoforget[vi2], ick_oo_twospots); ick_retrieve(ick_twospots+vi3, ick_TWOSPOT, vi3, ick_twoforget[vi3], ick_oo_twospots); } else ick_lose(IE000, emitlineno, errstr); return rv; } /* Do a NEXT or goto. Gotos don't work with an empty NEXT stack, but that's trivial to correct by doing a NEXT at the start of the program. */ /*@maynotreturn@*/ void ick_dogoto(unsigned long linelabel, int emitlineno, int isnext) { /* OK, so auto is never necessary, but the point here is that this is being stored on the stack deliberately so that it can be recalled if this procedure is longjmped to. */ auto volatile int nextlevel = ick_nextindex; if(ick_printflow&&linelabel<=65535&&isnext) fprintf(stderr,"[next:%lu]",linelabel); ick_global_checkmode = 2; /* look for linelabels */ ick_global_linelabel = linelabel; /* If there was a FORGET earlier, implement it now, by removing the relevant NEXT stack entries. Unfortunately, we can't remove them from the main C stack if we care about the return address of this NEXT. If this is a GOTO rather than a NEXT, it's safe to go back to the top NEXT on the NEXT stack and redo it with a different target (because the return address will still be correct), and all FORGETs work using an implied GOTO. (COME FROMs work by telling the suckpoint to GOTO them.) */ if(!isnext) { if(ick_printflow&&ick_forgetamount) fprintf(stderr,"[forget:%d]",ick_forgetamount); else if(ick_printflow&&linelabel<=65535) fprintf(stderr,"[goto:%lu]",linelabel); nextlevel = ick_nextindex -= ick_forgetamount + 1; ick_forgetamount = 0; if(ick_nextindex < 0) ick_nextindex = 0; longjmp(ick_next_jmpbufs[ick_nextindex],2); } else if(ick_nextindex==81) ick_lose(IE123, emitlineno, (const char*)NULL); /* longjmp return codes: 1 = resume, 2 = redo to a different target */ if(setjmp(ick_next_jmpbufs[ick_nextindex])==1) { /* Returning from the next. Clean up the next stack, just in case the callee didn't. */ ick_nextindex = nextlevel; ick_global_checkmode=0; return; } ick_nextindex = nextlevel; /* in case we were longjmped to */ ++ick_nextindex; ick_allecfuncs(); /* If the checkmode is 4, we didn't find a target. */ if(ick_global_checkmode == 4) ick_lose(IE129, emitlineno, (const char*) NULL); /* Otherwise, the function called return(). */ ick_doresume(1,emitlineno); } /* Schedule a FORGET. The actual FORGET is performed at the next GOTO, which should happen immediately. */ void ick_scheduleforget(unsigned short amount) { ick_forgetamount += amount; if(ick_forgetamount >= ick_nextindex) ick_forgetamount = ick_nextindex-1; } /* Resume to a previous NEXT stack entry. */ /*@noreturn@*/ void ick_doresume(unsigned short amount, int emitlineno) { if(ick_printflow) fprintf(stderr,"[resume:%hu]",amount); if(ick_forgetamount) ick_lose(IE778, emitlineno, (const char *)NULL); if(!amount) ick_lose(IE621, emitlineno, (const char *)NULL); ick_nextindex -= amount; if(ick_nextindex < 1) /* the very first NEXT can't be RESUMEd to */ ick_lose(IE632, emitlineno, (const char *)NULL); longjmp(ick_next_jmpbufs[ick_nextindex],1); } /* Run any ick_startup blocks. */ void ick_runstartups(void) { ick_global_checkmode = 6; ick_allecfuncs(); ick_global_checkmode = 0; } /* Check to see if anything tries to steal control from a suckpoint. * This allows line labels > 65535, but bear in mind that such high * line labels cannot be COME FROM or NEXTed FROM or to by the user. * ('High' line labels are used by the implementation to implement * this function, but only as goto targets.) */ /*@maynotreturn@*/ void ick_checksuckpoint(unsigned long linelabel) { /* Check to see if any suckpoints aim here; if not, return. */ ick_global_checkmode=1; ick_global_goto=0; ick_global_linelabel=linelabel; ick_allecfuncs(); if(!ick_global_goto) {ick_global_checkmode=0; return;} /* If this was a COME FROM, goto it. */ if(ick_global_checkmode == 1) { if(ick_printflow) fprintf(stderr,"[comefrom:%lu]",ick_global_linelabel); ick_dogoto(ick_global_goto,-1,0); /* GOTO */ } else if(ick_global_checkmode == 3) { if(ick_printflow) fprintf(stderr,"[nextfrom:%lu]",ick_global_linelabel); ick_dogoto(ick_global_goto,-1,1); /* NEXT */ return; /* we were RESUMEd to */ } /* This line should be unreachable. */ ick_lose(IE778, -1, (const char *)NULL); } uint16_t ick_getonespot(unsigned short extername) { int i=-1; while(++i,1) { if(ick_ec_vars[i].ick_ec_vartype==ICK_EC_VARS_END) break; if(ick_ec_vars[i].ick_ec_vartype==ick_ONESPOT) if(ick_ec_vars[i].ick_ec_extername==extername) return ick_onespots[ick_ec_vars[i].ick_ec_intername]; } ick_lose(IE200,-1,(const char*)NULL); } void ick_setonespot(unsigned short extername, uint16_t value) { int i=-1; while(++i,1) { if(ick_ec_vars[i].ick_ec_vartype==ICK_EC_VARS_END) break; if(ick_ec_vars[i].ick_ec_vartype==ick_ONESPOT) if(ick_ec_vars[i].ick_ec_extername==extername) { if(ick_oneforget[ick_ec_vars[i].ick_ec_intername]) return; ick_onespots[ick_ec_vars[i].ick_ec_intername]=value; return; } } ick_lose(IE200,-1,(const char*)NULL); } uint32_t ick_gettwospot(unsigned short extername) { int i=-1; while(++i,1) { if(ick_ec_vars[i].ick_ec_vartype==ICK_EC_VARS_END) break; if(ick_ec_vars[i].ick_ec_vartype==ick_TWOSPOT) if(ick_ec_vars[i].ick_ec_extername==extername) return ick_twospots[ick_ec_vars[i].ick_ec_intername]; } ick_lose(IE200,-1,(const char*)NULL); } void ick_settwospot(unsigned short extername, uint32_t value) { int i=-1; while(++i,1) { if(ick_ec_vars[i].ick_ec_vartype==ICK_EC_VARS_END) break; if(ick_ec_vars[i].ick_ec_vartype==ick_TWOSPOT) if(ick_ec_vars[i].ick_ec_extername==extername) { if(ick_twoforget[ick_ec_vars[i].ick_ec_intername]) return; ick_twospots[ick_ec_vars[i].ick_ec_intername]=value; return; } } ick_lose(IE200,-1,(const char*)NULL); } /* Register a CREATE target. This is just a wrapper for ick_registercreation that gets around scoping problems. */ void ick_create(const char* sig, unsigned long target) { ick_registercreation(sig, target); } /* Accessor and mutator functions for CREATE data */ int ick_c_i_width(int argpos) { return ((ick_createdata*)ick_global_createdata)[argpos].width; } int ick_c_i_isarray(int argpos) { return ((ick_createdata*)ick_global_createdata)[argpos].isarray; } unsigned short ick_c_i_varnumber(int argpos) { return ((ick_createdata*)ick_global_createdata)[argpos].varnumber; } uint32_t ick_c_i_value(int argpos) { return (uint32_t)(((ick_createdata*)ick_global_createdata)[argpos].value); } uint32_t ick_c_i_getvalue(int argpos) { if(!(((ick_createdata*)ick_global_createdata)[argpos].accessors.get)) return ick_c_i_value(argpos); return ((ick_createdata*)ick_global_createdata)[argpos].accessors. get(ick_c_i_value(argpos)); } void ick_c_i_setvalue(int argpos, uint32_t newval) { if(((ick_createdata*)ick_global_createdata)[argpos].accessors.set) ((ick_createdata*)ick_global_createdata)[argpos].accessors. set(newval,NULL); } intercal-0.29/src/fiddle.h0000644000175000017500000000273111435477314015324 0ustar brooniebroonie/* fiddle.h -- functions implementing intercal's operators */ /*@-exportlocal@*/ /* these are used, just in generated code */ extern unsigned int ick_mingle(register unsigned int r, register unsigned int s); extern unsigned int ick_iselect(register unsigned int r, register unsigned int s); extern unsigned int ick_and16(unsigned int n), ick_or16(unsigned int n), ick_xor16(unsigned int n), ick_fin16(unsigned int n); extern unsigned int ick_whirl16(unsigned int p, unsigned int n); extern unsigned int ick_and32(unsigned int n), ick_or32(unsigned int n), ick_xor32(unsigned int n), ick_fin32(unsigned int n); extern unsigned int ick_whirl32(unsigned int p, unsigned int n); /* AIS: Reversed operators */ extern unsigned int ick_rev_and16(unsigned int n), ick_rev_or16(unsigned int n), ick_rev_xor16(unsigned int n), ick_rev_fin16(unsigned int n); extern unsigned int ick_rev_whirl16(unsigned int p, unsigned int n); extern unsigned int ick_rev_and32(unsigned int n), ick_rev_or32(unsigned int n), ick_rev_xor32(unsigned int n), ick_rev_fin32(unsigned int n); extern unsigned int ick_rev_whirl32(unsigned int p, unsigned int n); /* AIS: Optimizer helper operators */ extern unsigned int ick_xselx(unsigned int x); extern unsigned int ick_setbitcount(unsigned int x); extern unsigned int ick_smudgeleft(unsigned int x); extern unsigned int ick_smudgeright(unsigned int x); /*@=exportlocal@*/ /* fiddle.h ends here */ intercal-0.29/src/parser.y0000644000175000017500000006327511443403272015413 0ustar brooniebroonie/***************************************************************************** NAME parser.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 several syntax extensions over the original INTERCAL-72 language. 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 "config.h" #include #include #include "sizes.h" #include "ick.h" #include "feh.h" #include "ick_lose.h" extern int yyerror(const char*); /* Intervene our ick_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 */ extern int mark112; /* AIS: Mark the tuple for W112 when it's created. */ static int lineuid=65537; /* AIS: a line number not used anywhere else */ static int cacsofar=0; /* AIS: Number of args in a CREATE statement */ static tuple *splat(int); static tuple *prevtuple = NULL; #define GETLINENO \ {if (stbeginline < 0) thisline = -stbeginline; \ else {thisline = stbeginline; stbeginline = 0;}} #define ACTION(x, nt, nn) \ {x = newtuple(); x->type = nt; x->ick_lineno = thisline; x->u.node = nn;} #define TARGET(x, nt, nn) \ {x = newtuple(); x->type = nt; x->ick_lineno = thisline; x->u.target = nn;} #define ACTARGET(x, nt, nn, nn2)\ {x = newtuple(); x->type = nt; x->ick_lineno = thisline;\ x->u.node = nn; x->u.target = nn2;} /* AIS : The macro above was added for ABSTAIN expr FROM. */ #define NEWFANGLED mark112 = 1; /* AIS: Added the mention of mark112 */ \ if (ick_traditional) ick_lose(IE111,iyylineno,(char*)NULL); else #define DESTACKSE1 sparkearsstack[sparkearslev--/32] >>= 1 #define DESTACKSPARKEARS DESTACKSE1; DESTACKSE1 %} %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 feh2.c depends on GETS being the least * statement type and on the order of the ones following. * When adding a new statement, also update MAXTYPES in ick.h * and the token list in feh2.c. * AIS: Note that although GETS is the lowest statement type (with index 0 * in feh2.c), UNKNOWN (i.e. a line that causes error 000) is an even * lower statement type, with index -1. perpet.c uses indexes 1 higher. * AIS: Added FROM, MANYFROM, TRY_AGAIN, COMPUCOME, GERUCOME, WHILE, three * NEXT FROM cases, and CREATE. Also added PREPROC; this is for when the * parser acts like a preprocessor, translating an INTERCAL statement into * a sequence of INTERCAL statements with the same net effect. * AIS: COME_FROM now merged with the label following it, * to distinguish it from COMPUCOME, in the lexer. This changes * the parser somewhat. */ %token UNKNOWN /* AIS: This is so comments can be REINSTATED */ %token GETS RESIZE NEXT GO_AHEAD GO_BACK FORGET RESUME STASH RETRIEVE IGNORE %token REMEMBER ABSTAIN REINSTATE %token DISABLE ENABLE MANYFROM GIVE_UP READ_OUT WRITE_IN /* AIS: */PIN %token COME_FROM NEXTFROMLABEL %token NEXTFROMEXPR NEXTFROMGERUND COMPUCOME GERUCOME %token PREPROC WHILE TRY_AGAIN %token CREATE %token COMPUCREATE FROM /* AIS: ONCE and AGAIN added, for multithread support; also, NOSPOT added, so that I can reserve _ for future use (it's nowhere in the grammar yet) */ %token MAYBE DO PLEASE NOT ONCE AGAIN MESH NOSPOT ick_ONESPOT ick_TWOSPOT ick_TAIL ick_HYBRID %token MINGLE SELECT UNKNOWNOP /* AIS: SPARK EARS */ SUB BY /* AIS: For operand overloading */ %token SLAT BACKSLAT %token NUMBER UNARY OHOHSEVEN GERUND LABEL BADCHAR %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. */ /* AIS: Added new tokens for optimizer output */ %token SPLATTERED MESH32 %token C_AND C_OR C_XOR C_NOT C_LOGICALNOT C_LSHIFTBY C_RSHIFTBY %token C_NOTEQUAL C_A C_PLUS C_MINUS C_TIMES C_DIVIDEBY C_MODULUS %token C_GREATER C_LESS C_ISEQUAL C_LOGICALAND C_LOGICALOR /* The reverse unary operators have to be in the same order as the forward unary operators. */ %token AND OR XOR FIN WHIRL WHIRL2 WHIRL3 WHIRL4 WHIRL5 %token REV_AND REV_OR REV_XOR REV_FIN %token REV_WHIRL REV_WHIRL2 REV_WHIRL3 REV_WHIRL4 REV_WHIRL5 /* (AIS) Tokens for just-in-case compilation; UNKNOWNID is returned by the lexer for unknown 'identifiers'. And yes, it does contain a number. */ %token UNKNOWNID /* (AIS) Five possibilities for an unknown statement chain: identifiers, scalars, arrays, array elements, and other expressions. */ %token US_ID US_SCALAR US_ARRVAR US_ELEM US_EXPR %type expr limexpr varlist variable constant lvalue inlist outlist %type subscr byexpr scalar scalar2s ick_array initem outitem sublist %type unambig limunambig subscr1 sublist1 oparray osubscr osubscr1 %type notanlvalue nlunambig lunambig unknownstatement unknownatom %type unknownsin unknownsif unknownaid unop %type preproc perform mtperform %type please preftype %nonassoc OPENEARS OPENSPARK CLOSEEARS CLOSESPARK %nonassoc HIGHPREC %nonassoc UNARYPREC %nonassoc LOWPREC /* AIS: I reversed this precedence, to sort out the near-ambiguity. UNARYPREC and LOWPREC are to give the C-INTERCAL meaning of a statement precedence above its CLC-INTERCAL meaning. */ %% /* 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. * AIS: An exechance above 100 indicates a MAYBE situation (e.g. 4545 * means MAYBE DO %45 ...). This means %0 should be illegal. I modified * all these to allow for MAYBE. */ command : please mtperform {$2->label = 0; $2->exechance = $1 * 100;} | please OHOHSEVEN mtperform {$3->label = 0; $3->exechance = $1 * $2;} | LABEL please mtperform {checklabel($1); $3->label = $1; $3->exechance = $2 * 100;} | LABEL please OHOHSEVEN mtperform {checklabel($1); $4->label = $1; $4->exechance = $2 * $3;} | error {/* AIS: catch errors which occur after the end of a statement (highly likely when comments are being written, as the start of them will be parsed as an UNKNOWN) */ yyerrok; yyclearin; cacsofar=0; if(prevtuple) {prevtuple->type=SPLATTERED; splat(0);} else splat(1); /* this is the first statement */ } ; /* * AIS: added for the ONCE/AGAIN qualifiers. It copies a pointer to the tuple, * so command will set the values in the original tuple via the copy. * I also added prevtuple so that after-command splattering works. */ mtperform : preproc {$1->onceagainflag = onceagain_NORMAL; prevtuple = $$ = $1;} | preproc ONCE {NEWFANGLED {$1->onceagainflag = onceagain_ONCE; prevtuple = $$ = $1;}} | preproc AGAIN {NEWFANGLED {$1->onceagainflag = onceagain_AGAIN; prevtuple = $$ = $1;}} /* AIS: Either we do a simple 'perform', or preprocessing is needed. I wrote all of this. The way the preprocessor works is to add a whole load of new tuples. The tuples are written in the correct order, except for where one of the commands referenced in the preproc is needed; then one command from near the start is written, and swapped into place using tupleswap. ppinit must also be called giving the number of tuples at the end, to sort out each of the tuples. Note that preprocs can't be nested (so no DO a WHILE b WHILE c), and that lineuid can be used to create unreplicable numbers. preproc must also be set by hand on all commands that you want to be immune to ABSTAIN, etc., from outside the preproc, and $$ is set to the command that gets the line number and can be NEXTED to and from. */ preproc : perform {$$ = $1;} /* the simple case */ | perform WHILE perform { if(!multithread) ick_lose(IE405, iyylineno, (char*)NULL); NEWFANGLED{ /* (x) DO a WHILE b is equivalent to #11 (l0) DO REINSTATE (l3) #10 (l1) DO COME FROM (l2) AGAIN #9 DO b #8 DO COME FROM (l0) #7 DO NOTHING #6 DO NOTHING #5 (l2) DO NOTHING #4 DO GIVE UP #3 DO COME FROM (l0) #2 (x) DO a #1 (l3) DON'T ABSTAIN FROM (l1) AGAIN */ tuple* temptuple; TARGET(temptuple, COME_FROM, lineuid+2); temptuple->label=lineuid+1; temptuple->preproc=1; /* #10 */ TARGET(temptuple, COME_FROM, lineuid+0); temptuple->preproc=1; /* #8 */ ACTION(temptuple, PREPROC, 0); temptuple->preproc=1; /* #7 */ ACTION(temptuple, PREPROC, 0); temptuple->preproc=1; /* #6 */ ACTION(temptuple, PREPROC, 0); temptuple->label=lineuid+2; temptuple->preproc=1; /* #5 */ ACTION(temptuple, GIVE_UP, 0); temptuple->preproc=1; /* #4 */ TARGET(temptuple, COME_FROM, lineuid+0); temptuple->preproc=1; /* #3 */ TARGET(temptuple, REINSTATE, lineuid+3); temptuple->setweave=1; temptuple->label=lineuid+0; temptuple->preproc=1; /* #11 */ TARGET(temptuple, ABSTAIN, lineuid+1); temptuple->label=lineuid+3; /* #1 */ temptuple->preproc=1; temptuple->setweave=-1; temptuple->exechance=-100; politesse += 3; /* Keep the politeness checker happy */ ppinit(11); tupleswap(10,9); tupleswap(11,2); lineuid+=4; /* #2, #9 */ tuples[ick_lineno-10].onceagainflag=onceagain_AGAIN; tuples[ick_lineno-1].onceagainflag=onceagain_AGAIN; $$=&(tuples[ick_lineno-2]); }} /* There are two (AIS: now four) forms of preamble returned by the lexer */ please : DO {GETLINENO; $$ = 1;} | DO NOT {GETLINENO; $$ = -1;} | MAYBE {NEWFANGLED {GETLINENO; $$ = 101;}} | MAYBE NOT {NEWFANGLED {GETLINENO; $$ = -101;}} ; /* Here's how to parse statement bodies */ perform : lvalue GETS expr {ACTION($$, GETS, cons(GETS,$1,$3));} | ick_array GETS byexpr {ACTION($$, RESIZE, cons(RESIZE,$1,$3));} | notanlvalue GETS expr %prec LOWPREC {/* AIS: This is for variableconstants, and an error otherwise.*/ if(variableconstants) ACTION($$, GETS, cons(GETS,$1,$3)) else {yyerrok; yyclearin; $$=splat(1);}} | 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 FROM LABEL {stbeginline=0; TARGET($$, ABSTAIN, $3);} | ABSTAIN FROM gerunds {ACTION($$, DISABLE, rlist);} | ABSTAIN expr FROM LABEL {/* AIS */ NEWFANGLED {stbeginline=0; ACTARGET($$, FROM, $2, $4);}} | ABSTAIN expr FROM gerunds {/* AIS */ NEWFANGLED {$$ = newtuple(); $$->type = MANYFROM; $$->ick_lineno = thisline; \ {node* tempnode=newnode(); $$->u.node = tempnode; tempnode->lval=$2; tempnode->rval=rlist; tempnode->opcode=MANYFROM;}}} | 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);} | PIN scalar2s {ACTION($$, PIN, $2);} | GIVE_UP {ACTION($$, GIVE_UP, 0);} | GO_AHEAD {/* AIS */ NEWFANGLED {ACTION($$, GO_AHEAD, 0);}} | GO_BACK {/* AIS */ NEWFANGLED {ACTION($$, GO_BACK, 0);}} | TRY_AGAIN {/* AIS */ NEWFANGLED {ACTION($$,TRY_AGAIN,0);}} | COME_FROM {/* AIS: Modified */ NEWFANGLED {TARGET($$,COME_FROM,$1);}} | COMPUCOME gerunds {/* AIS: COME FROM gerund */ NEWFANGLED{ACTION($$,GERUCOME,rlist); compucomesused=1; gerucomesused=1;}} | COMPUCOME expr {/* AIS */NEWFANGLED {ACTION($$,COMPUCOME,$2); compucomesused=1;}} /* AIS: NEXT FROM works along the same lines as COME FROM */ | NEXTFROMLABEL {NEWFANGLED {TARGET($$,NEXTFROMLABEL,$1);} nextfromsused=1;} | NEXTFROMEXPR gerunds{NEWFANGLED{ACTION($$,NEXTFROMGERUND,rlist); compucomesused=1; gerucomesused=1;} nextfromsused=1;} | NEXTFROMEXPR expr {NEWFANGLED {ACTION($$,NEXTFROMEXPR,$2); compucomesused=1; nextfromsused=1;}} /* AIS: CREATE takes an 'unknown statement' as a template */ | CREATE unknownstatement {NEWFANGLED{ACTARGET($$,CREATE,$2,$1); cacsofar=0;}} | COMPUCREATE expr unknownsif {NEWFANGLED{ACTION($$,COMPUCREATE, cons(INTERSECTION,$2,$3)); cacsofar=0;}} /* AIS: or an unknown expression */ | CREATE unop {NEWFANGLED{ACTARGET($$,CREATE,$2,$1); cacsofar=0;}} | COMPUCREATE unambig unop {NEWFANGLED{ACTION($$,COMPUCREATE, cons(INTERSECTION,$2,$3)); cacsofar=0;}} /* AIS: Just-in-case compilation of unknown statements */ | unknownstatement {NEWFANGLED {ACTION($$,UNKNOWN,$1); cacsofar=0;}} /* AIS: Added the yyerrok */ | BADCHAR {yyclearin; yyerrok; $$ = splat(1); cacsofar=0;} | error {yyclearin; yyerrok; $$ = splat(1); cacsofar=0;} ; /* AIS: Unknown statements. The rule here is that we can't have two non-ID unknowns in a row, but two IDs in a row are acceptable. */ unknownstatement : unknownatom {$$ = $1; intern(ick_TWOSPOT,cacsofar+++1601);} | unknownsin unknownatom {$$=cons(INTERSECTION,$1,$2); intern(ick_TWOSPOT,cacsofar+++1601);} | unknownsin {$$ = $1;} ; unknownsif : unknownaid {$$ = $1;} | unknownaid unknownstatement {$$=cons(INTERSECTION,$1,$2);} unknownsin : unknownaid {$$ = $1;} | unknownstatement unknownaid {$$=cons(INTERSECTION,$1,$2);} /* Each of the possible unknown atoms, apart from arrays and IDs, generates operand overloading info if CREATEs or external calls are used, so that the implied overloading of a CREATE will work. */ unknownatom : subscr {$$=cons(US_ELEM,0,$1); if(createsused){ opoverused=1; if(!firstslat) firstslat=$1; else prevslat->nextslat=$1; prevslat=$1; $1->nextslat=0;}} | scalar {$$=cons(US_SCALAR,0,$1); if(createsused){ opoverused=1; if(!firstslat) firstslat=$1; else prevslat->nextslat=$1; prevslat=$1; $1->nextslat=0;}} | notanlvalue {$$=cons(US_EXPR,0,$1); if(createsused){ opoverused=1; if(!firstslat) firstslat=$1; else prevslat->nextslat=$1; prevslat=$1; $1->nextslat=0;}} | ick_array {$$=cons(US_ARRVAR,0,$1);} ; unknownaid : UNKNOWNID {$$=newnode(); $$->opcode=US_ID; $$->constant=$1;} ; /* 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 | ick_array; lvalue : scalar | subscr; scalar2s: ick_TWOSPOT NUMBER /* AIS: for TWOSPOTs only */ { $$ = newnode(); $$->opcode = ick_TWOSPOT; $$->constant = intern(ick_TWOSPOT, $2); } scalar : ick_ONESPOT NUMBER { $$ = newnode(); $$->opcode = ick_ONESPOT; $$->constant = intern(ick_ONESPOT, $2); } | ick_TWOSPOT NUMBER { $$ = newnode(); $$->opcode = ick_TWOSPOT; $$->constant = intern(ick_TWOSPOT, $2); } ; ick_array : ick_TAIL NUMBER { $$ = newnode(); $$->opcode = ick_TAIL; $$->constant = intern(ick_TAIL, $2); } | ick_HYBRID NUMBER { $$ = newnode(); $$->opcode = ick_HYBRID; $$->constant = intern(ick_HYBRID, $2); } ; /* Array with unary operator is a special intermediate case; these nodes will be rearranged when the subscript list is added */ oparray : ick_TAIL UNARY NUMBER %prec UNARYPREC { $$ = newnode(); $$->opcode = $2; $$->rval = newnode(); $$->rval->opcode = ick_TAIL; $$->rval->constant = intern(ick_TAIL, $3); } | ick_HYBRID UNARY NUMBER %prec UNARYPREC { $$ = newnode(); $$->opcode = $2; $$->rval = newnode(); $$->rval->opcode = ick_HYBRID; $$->rval->constant = intern(ick_HYBRID, $3); } ; /* And a constant looks like this */ constant: MESH NUMBER { /* enforce the 16-bit constant constraint */ if ((unsigned int)$2 > ick_Max_small) ick_lose(IE017, iyylineno, (char *)NULL); $$ = newnode(); $$->opcode = MESH; if(variableconstants) /* AIS */ $$->constant = intern(MESH, $2); else $$->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 | ick_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 | ick_array; outlist : outitem INTERSECTION outlist {$$=cons(INTERSECTION,$1,$3);} | outitem {$$=cons(INTERSECTION,$1,0);} ; /* Now the gnarly part -- expression syntax */ /* Support ick_array dimension assignment */ byexpr : expr BY byexpr {$$ = cons(BY, $1, $3);} | expr {$$ = cons(BY, $1, 0);} ; /* Support ick_array subscripts (as lvalues) */ subscr : subscr1 {$$ = $1;} | ick_array SUB sublist {$$ = cons(SUB, $1, $3);} ; subscr1 : ick_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);} ; /* AIS: Unknown operators */ unop : BADCHAR {$$ = newnode(); $$->opcode = BADCHAR; $$->constant = $1;} ; /* here goes the general expression syntax */ expr : unambig {$$ = $1;} /* AIS: CLC-INTERCAL allows right-association of SELECT and MINGLE. (Strangely, that simplifies this section somewhat.) */ | unambig SELECT expr {$$ = cons(SELECT, $1, $3);} | unambig MINGLE expr {$$ = cons(MINGLE, $1, $3);} | unambig unop expr {$$ = cons(UNKNOWNOP, $2, cons(INTERSECTION, $1, $3)); if(useickec && createsused) { if(!firstslat) firstslat=$1; else prevslat->nextslat=$1; $1->nextslat=$3; prevslat=$3; $3->nextslat=0; opoverused=1; intern(ick_TWOSPOT, 1601); intern(ick_TWOSPOT, 1602); intern(ick_TWOSPOT, 1603);}} /* AIS: Operand overloading */ | scalar SLAT expr {NEWFANGLED{$$ = cons(SLAT, $1, $3); opoverused=1; if(!firstslat) firstslat=$3; else prevslat->nextslat=$3; prevslat=$3; $3->nextslat=0;}} | subscr {$$ = $1;} | osubscr {$$ = $1;} ; /* AIS: Any expression that isn't an lvalue */ notanlvalue:nlunambig {$$ = $1;} | osubscr {$$ = $1;} | unambig SELECT expr {$$ = cons(SELECT, $1, $3);} | unambig MINGLE expr {$$ = cons(MINGLE, $1, $3);} | unambig unop expr {$$ = cons(UNKNOWNOP, $2, cons(INTERSECTION, $1, $3)); if(useickec && createsused) { if(!firstslat) firstslat=$1; else prevslat->nextslat=$1; $1->nextslat=$3; prevslat=$3; $3->nextslat=0; opoverused=1; intern(ick_TWOSPOT, 1601); intern(ick_TWOSPOT, 1602); intern(ick_TWOSPOT, 1603);}} | scalar SLAT expr {NEWFANGLED{$$ = cons(SLAT, $1, $3); opoverused=1; if(!firstslat) firstslat=$3; else prevslat->nextslat=$3; prevslat=$3; $3->nextslat=0;}} ; /* AIS: an expr that doesn't start with a unary operator */ limexpr : limunambig {$$ = $1;} | limunambig SELECT expr {$$ = cons(SELECT, $1, $3);} | limunambig MINGLE expr {$$ = cons(MINGLE, $1, $3);} | limunambig unop expr {$$ = cons(UNKNOWNOP, $2, cons(INTERSECTION, $1, $3)); if(useickec && createsused) { if(!firstslat) firstslat=$1; else prevslat->nextslat=$1; $1->nextslat=$3; prevslat=$3; $3->nextslat=0; opoverused=1; intern(ick_TWOSPOT, 1601); intern(ick_TWOSPOT, 1602); intern(ick_TWOSPOT, 1603);}} | scalar SLAT expr {NEWFANGLED{$$ = cons(SLAT, $1, $3); opoverused=1; if(!firstslat) firstslat=$3; else prevslat->nextslat=$3; prevslat=$3; $3->nextslat=0;}} | subscr {$$ = $1;} | osubscr {$$ = $1;} ; preftype: MESH {$$=MESH; } | ick_ONESPOT {$$=ick_ONESPOT;} | ick_TWOSPOT {$$=ick_TWOSPOT;}; /* AIS: unambig split into limunambig (unambigs that don't start with a unary operator), nlunambig (unambigs that aren't lvalues), lunambig (both), and unambig (the general case) */ lunambig: constant {$$ = $1;} /* deal with the bizarre unary-op syntax */ | preftype UNARY NUMBER %prec UNARYPREC { $$ = newnode(); $$->opcode = $2; $$->rval = newnode(); $$->rval->opcode = $1; if($1 == MESH) { /* enforce the 16-bit constant constraint */ if ((unsigned int)$3 > ick_Max_small) ick_lose(IE017, iyylineno, (char *)NULL); if(variableconstants) /* AIS, patched by JH */ $$->rval->constant = intern(MESH, $3); else $$->rval->constant = $3; } else { $$->rval->constant = intern($1, $3); } } /* Now deal with the screwy unary-op interaction with grouping */ /* AIS: Modified to allow for maintenance of the SPARK/EARS stack */ | eitherspark UNARY expr CLOSESPARK %prec UNARYPREC { $$ = newnode(); $$->opcode = $2; $$->rval = $3; DESTACKSPARKEARS; } | eitherears UNARY expr CLOSEEARS %prec UNARYPREC { $$ = newnode(); $$->opcode = $2; $$->rval = $3; DESTACKSPARKEARS; } /* AIS: limexpr, a limited expression that isn't allowed to start with a unary operator, is used here to avoid a reduce/reduce conflict. */ | eitherspark limexpr CLOSESPARK {$$ = $2; DESTACKSPARKEARS;} | eitherears limexpr CLOSEEARS {$$ = $2; DESTACKSPARKEARS;} ; limunambig: lunambig {$$ = $1;} | scalar {$$ = $1;} ; nlunambig: lunambig {$$ = $1;} | UNARY unambig %prec LOWPREC {$$=newnode(); $$->opcode = $1; $$->rval = $2;} ; /* AIS: A bit of CLC-INTERCAL compatibility here. The syntax now allows any number of unary operators before, and one inside, an expression. In ambiguous cases like '&VV#1~#5', the & applies to the whole expression (one operator inside is allowed, and inside takes precedence), but the Vs apply just to the #1, because only one operator inside is allowed. */ unambig : limunambig {$$ = $1;} | UNARY unambig %prec LOWPREC {$$=newnode(); $$->opcode = $1; $$->rval = $2;} ; eitherspark : OPENSPARK ; | CLOSESPARK ; ; eitherears : OPENEARS ; | CLOSEEARS ; ; %% static tuple *splat(int gentuple) /* 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 ick_next DO, PLEASE or label, then unget that token. * which we can do with a tricky flag on the lexer (re_send_token). */ if(re_send_token == true) /* By AIS */ { /* We're still cleaning up from the previous error. */ return prevtuple; } /* fprintf(stderr,"attempting to splat at line %d....\n",iyylineno); */ /* AIS: Set the flag to true the first time round, false for subsequent iterations. That way, if the error was triggered on a DO or label, we use that token as the start of the next statement. */ for(i = 0,re_send_token = true;;i++,re_send_token = false) { tok = lexer(); if (!tok) { re_send_token = true; tok = ' '; /* scanner must not see a NUL */ break; } else if (tok == DO || tok == PLEASE || tok == LABEL /* AIS */ || tok == MAYBE) { re_send_token = true; break; } } /* fprintf(stderr,"found %d on line %d after %d other tokens.\n", tok,iyylineno,i); */ /* generate a placeholder tuple for the text line */ if(gentuple /* AIS */) {TARGET(sp, SPLATTERED, 0); prevtuple=sp;} else sp=NULL; return(sp); } /* parser.y ends here */ intercal-0.29/src/PaxHeaders.9599/0000755000175000017500000000000011577237112016360 5ustar brooniebroonieintercal-0.29/src/PaxHeaders.9599/numerals.c0000644000175000017500000000013211545350337020346 0ustar brooniebroonie30 mtime=1284376106.157383398 30 atime=1298756058.392873988 30 ctime=1301663961.754750518 intercal-0.29/src/PaxHeaders.9599/ick_bool.h0000644000175000017500000000013211545350337020306 0ustar brooniebroonie30 mtime=1285582211.778540737 30 atime=1298756058.332874146 30 ctime=1301663961.634753397 intercal-0.29/src/PaxHeaders.9599/pickwrap.c0000644000175000017500000000013211545350337020340 0ustar brooniebroonie30 mtime=1282834124.237909011 30 atime=1298756058.620873643 30 ctime=1301663961.502751729 intercal-0.29/src/PaxHeaders.9599/idiotism.oil0000644000175000017500000000013211545350337020702 0ustar brooniebroonie30 mtime=1284376816.389062823 30 atime=1298756058.585060032 30 ctime=1301663961.870751821 intercal-0.29/src/PaxHeaders.9599/pick2.h0000644000175000017500000000013111545350337017534 0ustar brooniebroonie30 mtime=1282834124.237909011 30 atime=1298756058.624883136 29 ctime=1301663964.88276272 intercal-0.29/src/PaxHeaders.9599/dekludge.c0000644000175000017500000000013211545350337020304 0ustar brooniebroonie30 mtime=1284376250.892336303 30 atime=1298756058.544873963 30 ctime=1301663961.962750087 intercal-0.29/src/PaxHeaders.9599/ick-wrap.c0000644000175000017500000000013211545350337020235 0ustar brooniebroonie30 mtime=1282834124.233909571 30 atime=1298756058.305912178 30 ctime=1301663961.478751218 intercal-0.29/src/PaxHeaders.9599/clc-cset.c0000644000175000017500000000013111545350337020214 0ustar brooniebroonie29 mtime=1284376106.14014794 30 atime=1298756058.276874084 30 ctime=1301663961.814749601 intercal-0.29/src/PaxHeaders.9599/latin1.bin0000644000175000017500000000013211545350337020236 0ustar brooniebroonie30 mtime=1282834124.237909011 30 atime=1298756058.872874682 30 ctime=1301663961.454752805 intercal-0.29/src/PaxHeaders.9599/fiddle.c0000644000175000017500000000013211545350337017747 0ustar brooniebroonie30 mtime=1282834124.233909571 30 atime=1298756058.421905094 30 ctime=1301663961.782750198 intercal-0.29/src/PaxHeaders.9599/ick_ec.c0000644000175000017500000000013111545350337017734 0ustar brooniebroonie30 mtime=1284376106.144148434 29 atime=1298756058.38487421 30 ctime=1301663961.838752838 intercal-0.29/src/PaxHeaders.9599/fiddle.h0000644000175000017500000000013211545350337017754 0ustar brooniebroonie30 mtime=1282834124.233909571 30 atime=1298756058.692875076 30 ctime=1301663961.574753475 intercal-0.29/src/PaxHeaders.9599/parser.y0000644000175000017500000000013211545350337020042 0ustar brooniebroonie30 mtime=1284376250.968450932 30 atime=1301663960.462758051 30 ctime=1301663964.910749894 intercal-0.29/src/PaxHeaders.9599/yuk.c0000644000175000017500000000013211545350337017330 0ustar brooniebroonie30 mtime=1284376106.180148128 30 atime=1298756058.212873545 30 ctime=1301663961.874750148 intercal-0.29/src/PaxHeaders.9599/lexer.l0000644000175000017500000000013211545350337017650 0ustar brooniebroonie30 mtime=1284376250.936810654 30 atime=1301663960.906750249 30 ctime=1301663964.914750737 intercal-0.29/src/PaxHeaders.9599/cesspool.c0000644000175000017500000000013211545350337020347 0ustar brooniebroonie30 mtime=1284376816.360246825 30 atime=1298756058.236874627 30 ctime=1301663961.726750139 intercal-0.29/src/PaxHeaders.9599/ebcdic.bin0000644000175000017500000000013211545350337020257 0ustar brooniebroonie30 mtime=1282834124.233909571 30 atime=1298756058.344874128 30 ctime=1301663961.434750971 intercal-0.29/src/PaxHeaders.9599/uncommon.h0000644000175000017500000000013211545350337020360 0ustar brooniebroonie30 mtime=1284376250.981447594 30 atime=1298756058.644874307 30 ctime=1301663964.902752332 intercal-0.29/src/PaxHeaders.9599/yuk.h0000644000175000017500000000013111545350337017334 0ustar brooniebroonie30 mtime=1284376106.180148128 30 atime=1298756058.572873083 29 ctime=1301663961.62275094 intercal-0.29/src/PaxHeaders.9599/oil.h0000644000175000017500000000013211545350337017310 0ustar brooniebroonie30 mtime=1284376250.951621608 30 atime=1298756058.688874942 30 ctime=1301663964.858758856 intercal-0.29/src/PaxHeaders.9599/pick1.h0000644000175000017500000000013211545350337017534 0ustar brooniebroonie30 mtime=1282834124.237909011 30 atime=1298756058.356873622 30 ctime=1301663964.874749862 intercal-0.29/src/PaxHeaders.9599/perpet.c0000644000175000017500000000013211545350337020017 0ustar brooniebroonie30 mtime=1285591311.141759084 30 atime=1298756058.444873491 30 ctime=1301663961.995594717 intercal-0.29/src/PaxHeaders.9599/sizes.h0000644000175000017500000000013011545350337017660 0ustar brooniebroonie29 mtime=1282834124.24190873 30 atime=1298756058.868878948 29 ctime=1301663964.89474988 intercal-0.29/src/PaxHeaders.9599/ick.h0000644000175000017500000000013211545350337017273 0ustar brooniebroonie30 mtime=1284376250.908147748 30 atime=1298756058.192872946 30 ctime=1301663964.846749556 intercal-0.29/src/PaxHeaders.9599/baudot.bin0000644000175000017500000000013111545350337020323 0ustar brooniebroonie30 mtime=1282834124.229909433 29 atime=1298756058.38487421 30 ctime=1301663961.414751442 intercal-0.29/src/PaxHeaders.9599/feh.h0000644000175000017500000000013211545350337017267 0ustar brooniebroonie30 mtime=1284376250.892336303 30 atime=1298756058.352874955 30 ctime=1301663964.834758693 intercal-0.29/src/PaxHeaders.9599/feh2.c0000644000175000017500000000013211545350337017344 0ustar brooniebroonie30 mtime=1284376816.376147597 30 atime=1298756058.704873452 30 ctime=1301663961.948712011 intercal-0.29/src/PaxHeaders.9599/oil.y0000644000175000017500000000013211545350337017331 0ustar brooniebroonie30 mtime=1284376816.389062823 30 atime=1301663959.570749702 30 ctime=1301663961.998750677 intercal-0.29/src/PaxHeaders.9599/atari.bin0000644000175000017500000000013211545350337020146 0ustar brooniebroonie30 mtime=1282834124.229909433 30 atime=1298756058.288873998 30 ctime=1301663961.402754994 intercal-0.29/src/PaxHeaders.9599/ick_lose.h0000644000175000017500000000013111545350337020314 0ustar brooniebroonie30 mtime=1284376106.144148434 30 atime=1298756058.408877736 29 ctime=1301663961.60275071 intercal-0.29/src/PaxHeaders.9599/abcessh.in0000644000175000017500000000013111545350337020313 0ustar brooniebroonie30 mtime=1285582247.454315592 30 atime=1301663613.026749339 29 ctime=1301663961.68275519 intercal-0.29/src/PaxHeaders.9599/bin2c.c0000644000175000017500000000013211545350337017515 0ustar brooniebroonie30 mtime=1284376106.137619301 30 atime=1298756058.657456424 30 ctime=1301663961.894749887 intercal-0.29/src/PaxHeaders.9599/ick_ec.h0000644000175000017500000000013211545350337017742 0ustar brooniebroonie30 mtime=1284376106.144148434 30 atime=1298756058.840874798 30 ctime=1301663961.554752966 intercal-0.29/src/PaxHeaders.9599/ick_lose.c0000644000175000017500000000013211545350337020310 0ustar brooniebroonie30 mtime=1284376250.925228506 30 atime=1298756058.784875506 30 ctime=1301663961.770753468 intercal-0.29/src/PaxHeaders.9599/arrgghh.c0000644000175000017500000000013211545350337020142 0ustar brooniebroonie30 mtime=1284376106.137619301 30 atime=1298756058.856873657 30 ctime=1301663961.794749791 intercal-0.29/src/PaxHeaders.9599/unravel.c0000644000175000017500000000013111545350337020173 0ustar brooniebroonie29 mtime=1282834124.24190873 30 atime=1298756058.368875421 30 ctime=1301663961.854751456 intercal-0.29/src/PaxHeaders.9599/uncommon.c0000644000175000017500000000013111545350337020352 0ustar brooniebroonie30 mtime=1284376250.981447594 29 atime=1298756058.37687457 30 ctime=1301663961.826752826 intercal-0.29/src/PaxHeaders.9599/convickt.c0000644000175000017500000000013211545350337020340 0ustar brooniebroonie30 mtime=1284376816.360246825 30 atime=1298756058.632874255 30 ctime=1301663961.914751861 intercal-0.29/src/PaxHeaders.9599/cooptsh.in0000644000175000017500000000013211545350337020363 0ustar brooniebroonie30 mtime=1284376703.320148588 30 atime=1301663612.854751547 30 ctime=1301663961.690752684 intercal-0.29/src/yuk.c0000644000175000017500000006272111443403052014670 0ustar brooniebroonie/**************************************************************************** NAME yuk.c -- C-INTERCAL debugger and profiler code, linked into programs. DESCRIPTION File linked into programs as a debugger or profiler. LICENSE TERMS Copyright (C) 2006 Alex Smith 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 "config.h" /* AIS: Generated by autoconf */ #include #include #ifdef HAVE_SYS_TIME_H # include # ifdef TIME_WITH_SYS_TIME # include # endif #else # include #endif #include #ifdef HAVE_UNISTD_H # include #endif #include #include #define YUKDEBUG 1 #include "yuk.h" #include "ick_lose.h" #include "sizes.h" #include "abcess.h" #include "uncommon.h" #if YPTIMERTYPE == 4 #include #endif extern signed char onewatch[]; extern signed char twowatch[]; extern ick_type16 oneold[]; extern ick_type32 twoold[]; char** globalargv; int globalargc; int yuklines = 0; int yukloop = 0; int yukcommands = 0; /* these 5 lines because externs must be defined somewhere */ /* Global variable storage types: static: limited to the file unadorned: defining an extern extern: defined elsewhere (unless initialised) */ static char buf[21]; static sig_atomic_t singlestep = 1; /* if 0, run until a breakpoint */ static sig_atomic_t writelines = 1; /* whether to display executed lines onscreen */ static int breakpoints[80]; /* initialised to all 0s. Breakpoint locations */ static int nbreakpoints = 1; /* how many breakpoints we have */ static int monitors[80]; /* monitors give a message when program flow passes them */ static int nmonitors = 0; static int untilnext = -1; /* NEXTING level to break the program at */ static int firstrun = 1; /* ick_first time an interactive command point is reached */ static int yukerrcmdg = -1; /* the aboff that indicates an error in the 'g' command */ static yptimer tickcount; /* yptimer of last run */ static int lastaboff = 0; /* last value of aboff */ static void handlesigint(int i) { /* this is a signal handler, so can't do much */ singlestep = 1; writelines = 1; /*@-noeffect@*/ (void) i; /*@=noeffect@*/ } #if YPTIMERTYPE==1 || YPTIMERTYPE==2 static yptimer yukgettimeofday() { static struct timeval tp; yptimer temp; /* gettimeofday is POSIX; config.sh has checked that it's available, so turn off the unrecog warning */ /*@-unrecog@*/ gettimeofday(&tp,0); /*@=unrecog@*/ temp=(yptimer)tp.tv_usec + (yptimer)tp.tv_sec * (yptimer)1000000LU; /* here we make use of unsigned wraparound. In the case YPTIMERTYPE == 1, it seems quite likely that we're going to wraparound, but because everything is cast to the unsigned integral type yptimer, we get a value that will wraparound in such a way that - will give us the correct time interval. */ return temp; } #elif YPTIMERTYPE == 4 yptimer yuktimes() { static struct tms tp; times(&tp); return tp.tms_utime + tp.tms_stime; } #elif YPTIMERTYPE == 5 static yptimer yukclock_gettime() { static struct timespec ts; yptimer temp; /* We've checked that this function is available; -lrt will be linked in. */ /*@-unrecog@*/ #if defined(_POSIX_CPUTIME) && _POSIX_CPUTIME > 0 clock_gettime(CLOCK_PROCESS_CPUTIME_ID,&ts); #else # if defined(_POSIX_THREAD_CPUTIME) && _POSIX_THREAD_CPUTIME > 0 clock_gettime(CLOCK_THREAD_CPUTIME_ID,&ts); # else # if defined(_POSIX_MONOTONIC_CLOCK) && _POSIX_MONOTONIC_CLOCK > 0 clock_gettime(CLOCK_MONOTONIC,&ts); # else # ifndef CLOCK_REALTIME # error clock_gettime is defined, but no clocks seem to be; try changing YPTIMERTYPE in src/yuk.h # endif clock_gettime(CLOCK_REALTIME,&ts); # endif # endif #endif /*@=unrecog@*/ temp=(yptimer)ts.tv_nsec + (yptimer)ts.tv_sec * (yptimer)1000000000LU; /* using wraparound as with gettimeofday */ return temp; } #endif /* YPTIMERTYPE */ void yukterm(void) { int i,lastline,thisline,inrow=0; yptimer avgtime,avgtime2; FILE *dummy; if(yukopts==2) (void) puts("Program ended without error."); if(!(yukopts&1)) return; /* Print profiling information */ (void) puts("Profiling information saved to \"yuk.out\"."); /* Bletch. GCC's unsuppressible warning forces us to this */ dummy = freopen("yuk.out","w",stdout); i=-1; lastline=-1; while(++i.\n"); (void) puts("For help on yuk, type ?.\n"); } i=nbreakpoints; broken=0; while(i--) broken|=breakpoints[i]==lineofaboff[aboff]; if(yukloop&&broken&&*breakpoints!=lineofaboff[aboff]) broken=0; if(broken) { if(*breakpoints!=lineofaboff[aboff]) printf("Breakpoint hit at line %d:\n",lineofaboff[aboff]); singlestep=1; } else { i=nmonitors; while(i--) broken|=monitors[i]==lineofaboff[aboff]; if(yukloop) broken=0; if(broken) printf("Command flowed past line %d:\n",lineofaboff[aboff]); } if(ick_nextindex <= untilnext) { broken = 1; singlestep = 1; } if(!broken&&yukerrcmdg==aboff) { singlestep = 1; (void) puts("There are no commands on that line."); /* To the user, nothing will have happened but the error message! */ } i=-1; while(++i,1) { if(yukvars[i].vartype==YUKEND) break; if(yukvars[i].vartype==ick_ONESPOT) { if(onewatch[yukvars[i].intername] != (char)0) { if(ick_onespots[yukvars[i].intername]!=oneold[yukvars[i].intername]&& onewatch[yukvars[i].intername]>(char)1) { oneold[yukvars[i].intername]=ick_onespots[yukvars[i].intername]; if(onewatch[yukvars[i].intername]==(char)2||!ick_onespots[yukvars[i].intername]) { /*@-formatconst@*/ /* it's safe, I checked it */ printf(onewatch[yukvars[i].intername]==(char)2? "Variable .%d changed.\n":"Variable .%d became 0.\n", yukvars[i].extername); /*@=formatconst@*/ broken=1; singlestep=1; } } if(writelines||broken) { printf(".%d is:\n",yukvars[i].extername); ick_pout(ick_onespots[yukvars[i].intername]); } } } if(yukvars[i].vartype==ick_TWOSPOT) { if(twowatch[yukvars[i].intername] != (char)0) { if(ick_twospots[yukvars[i].intername]!=twoold[yukvars[i].intername]&& twowatch[yukvars[i].intername] > (char)1) { twoold[yukvars[i].intername]=ick_twospots[yukvars[i].intername]; if(twowatch[yukvars[i].intername]==(char)2||!ick_twospots[yukvars[i].intername]) { /*@-formatconst@*/ /* there's just the one %d each way round */ printf(twowatch[yukvars[i].intername]==(char)2? "Variable :%d changed.\n":"Variable :%d became 0.\n", yukvars[i].extername); /*@=formatconst@*/ broken=1; singlestep=1; } } if(writelines||broken) { printf(":%d is:\n",yukvars[i].extername); ick_pout(ick_twospots[yukvars[i].intername]); } } } } if(writelines||broken) { /* write line that we're on */ printf("%5d:\t%s\n",lineofaboff[aboff],text); /* write command within line that we're on */ tempcmd=aboff; while(tempcmd&&lineofaboff[--tempcmd]==lineofaboff[aboff]); printf("On C%d: Abstained %d time%s\n",aboff?aboff-tempcmd:1, ick_abstained[aboff]-yukloop,ick_abstained[aboff]-yukloop==1?".":"s."); } if(singlestep) { (void)signal(SIGINT,handlesigint); /* placing this line here means that a rapid ^C^C will terminate the program, if it's stuck in a loop somewhere */ keeplooping = 1; breakpoints[0] = 0; /* breakpoints[0] goes whenever a breakpoint is hit */ untilnext = -1; if(yukloop) { /* reverse the abstentions that g caused */ i = -1; while(++i\tabstain once from all non-ick_abstained commands on "); (void) puts("b\tset breakpoint at "); (void) puts("c\tcontinue execution until a breakpoint is reached"); (void) puts("d\tdelete breakpoint at "); (void) puts("e\texplain the ick_main expression on "); (void) puts("f\tstop producing messages when commands on are run"); (void) puts("g\tchange currently executing command to the ick_first command"); (void) puts("\ton or the ick_next command if already on "); (void) puts("h\tlist 10 lines either side of the current line"); (void) puts("i\tignore a variable"); (void) puts("j\tremember a variable"); (void) puts("k\tcontinue until we RESUME back to the current nexting level"); (void) puts("\t(that is, step unless we are on a NEXT, in which case execute"); (void) puts("\tuntil a RESUME or FORGET back to the same or smaller NEXT stack)"); (void) puts("l\tlist 10 lines either side of "); (void) puts("m\tproduce a message every time a command on is run"); (void) puts("n\tshow the NEXT stack"); (void) puts("o\tcontinue until we RESUME/FORGET below the current nexting level"); (void) puts("\tie until the NEXT stack becomes smaller than it is at present"); (void) puts("p\tdisplay the values of all onespot and twospot variables"); (void) puts("q\tabort execution"); (void) puts("r\treinstate once all ick_abstained commands on "); (void) puts("s\texecute one command"); (void) puts("t\tcontinue until a breakpoint, displaying all lines executed"); (void) puts("u\texecute until just before is reached"); (void) puts("v\tshow value of variable every time a command is printed"); (void) puts("w\tshow the current line and current command"); (void) puts("x\tremove a variable view, breakchange, or breakzero"); (void) puts("y\tview variable every displayed line, and break on change"); (void) puts("z\tview variable every displayed line, and break on zero"); (void) puts("\tview the value of a onespot or twospot variable"); (void) puts("<\tset the value of a onespot or twospot variable"); (void) puts("*\tview the GNU General Public License"); (void) puts("?\tview this help screen"); (void) puts("@\tview this help screen"); (void) puts("Line numbers refer to lines of source code, not line labels."); (void) puts("Listings have (Axxxxxx) at the start of each line: this shows"); (void) puts("the abstention status of each command on that line."); (void) puts("The values of variables must be input in proper INTERCAL"); (void) puts("notation (i.e. ONE TWO THREE), and are output as butchered"); (void) puts("Roman ick_numerals."); #ifdef __DJGPP__ (void) puts("You can press - to interrupt an executing program."); #else (void) puts("You can press -C to interrupt an executing program."); #endif break; case 'q': exit(0); /*@-unreachable@*/ break; /*@=unreachable@*/ case 'n': i=ick_nextindex; if(!i) { (void) puts("The NEXT stack is empty."); } else { (void) puts("Commands NEXTED from:"); while(i--) { /* write NEXT line */ printf("%5d:\t%s\n",lineofaboff[ick_next[i]-1], textlines[lineofaboff[ick_next[i]-1]]); /* write NEXT command within line */ tempcmd=(int)ick_next[i]; while(tempcmd&&lineofaboff[--tempcmd]==lineofaboff[ick_next[i]-1]); printf("NEXTED from command C%u: Abstained %d time%s\n",ick_next[i]-1? ick_next[i]-1-tempcmd:1,ick_abstained[ick_next[i]-1], ick_abstained[ick_next[i]-1]==1?".":"s."); } } break; case 'w': /* write line that we're on */ printf("%5d:\t%s\n",lineofaboff[aboff],text); /* write command within line that we're on */ tempcmd=aboff; while(tempcmd&&lineofaboff[--tempcmd]==lineofaboff[aboff]); printf("On C%d: Abstained %d time%s\n",aboff?aboff-tempcmd:1,ick_abstained[aboff], ick_abstained[aboff]==1?".":"s."); break; case 'p': i=-1; while(++i,1) { if(yukvars[i].vartype==YUKEND) break; if(yukvars[i].vartype==ick_ONESPOT) { printf("Variable .%d is:\n",yukvars[i].extername); ick_pout(ick_onespots[yukvars[i].intername]); } if(yukvars[i].vartype==ick_TWOSPOT) { printf("Variable :%d is:\n",yukvars[i].extername); ick_pout(ick_twospots[yukvars[i].intername]); } } break; case '.': case ':': temp = sscanf(buf+1,"%d",&templine); if(templine<1 || temp != 1) { (void) puts("Don't know which variable you mean."); break; } i=-1; temp=0; while(++i,!temp) { if(yukvars[i].vartype==YUKEND) break; if((*buf=='.'&&yukvars[i].vartype==ick_ONESPOT)|| (*buf==':'&&yukvars[i].vartype==ick_TWOSPOT)) { if(yukvars[i].extername==templine) { temp=1; if(yukvars[i].vartype==ick_ONESPOT) { ick_pout(ick_onespots[yukvars[i].intername]); (void) puts(ick_oneforget[yukvars[i].intername]? "This variable is currently ignored.": "This variable is currently remembered."); } if(yukvars[i].vartype==ick_TWOSPOT) { ick_pout(ick_twospots[yukvars[i].intername]); (void) puts(ick_twoforget[yukvars[i].intername]? "This variable is currently ignored.": "This variable is currently remembered."); } } } } if(temp) break; (void) puts("That variable is not in the program."); break; case 'v': case 'x': case 'y': case 'z': if(buf[1]!='.'&&buf[1]!=':') { (void) puts("This command only works on onespot and twospot variables."); break; } temp = sscanf(buf+2,"%d",&templine); if(templine<1 || temp != 1) { (void) puts("Don't know which variable you mean."); break; } i=-1; temp=0; while(++i,!temp) { if(yukvars[i].vartype==YUKEND) break; if(yukvars[i].extername==templine) { if(buf[1]=='.'&&yukvars[i].vartype==ick_ONESPOT) { if(*buf=='v') onewatch[yukvars[i].intername]=(char)1; if(*buf=='x') onewatch[yukvars[i].intername]=(char)0; if(*buf=='y') onewatch[yukvars[i].intername]=(char)2; if(*buf=='z') onewatch[yukvars[i].intername]=(char)3; oneold[yukvars[i].intername]=ick_onespots[yukvars[i].intername]; temp=1; } if(buf[1]==':'&&yukvars[i].vartype==ick_TWOSPOT) { if(*buf=='v') twowatch[yukvars[i].intername]=(char)1; if(*buf=='x') twowatch[yukvars[i].intername]=(char)0; if(*buf=='y') twowatch[yukvars[i].intername]=(char)2; if(*buf=='z') twowatch[yukvars[i].intername]=(char)3; twoold[yukvars[i].intername]=ick_twospots[yukvars[i].intername]; temp=1; } } } if(!temp) { (void) puts("That variable is not in the program."); break; } if(*buf=='v') (void) puts("Set a normal variable view."); if(*buf=='x') (void) puts("Removed all views from that variable."); if(*buf=='y') (void) puts("Set a breakchange variable view."); if(*buf=='z') (void) puts("Set a breakzero variable view."); break; case 'i': case 'j': if(buf[1]!='.'&&buf[1]!=':'&&buf[1]!=','&&buf[1]!=';') { (void) puts("That isn't a real sort of variable."); break; } temp = sscanf(buf+2,"%d",&templine); if(templine<1 || temp != 1) { (void) puts("Don't know which variable you mean."); break; } i=-1; temp=0; while(++i,!temp) { if(yukvars[i].vartype==YUKEND) break; if((buf[1]=='.'&&yukvars[i].vartype==ick_ONESPOT)|| (buf[1]==':'&&yukvars[i].vartype==ick_TWOSPOT)|| (buf[1]==','&&yukvars[i].vartype==ick_TAIL)|| (buf[1]==';'&&yukvars[i].vartype==ick_HYBRID)) { if(yukvars[i].extername==templine) { temp=1; if(yukvars[i].vartype==ick_ONESPOT) ick_oneforget[yukvars[i].intername]=*buf=='i'; if(yukvars[i].vartype==ick_TWOSPOT) ick_twoforget[yukvars[i].intername]=*buf=='i'; if(yukvars[i].vartype==ick_TAIL) ick_tailforget[yukvars[i].intername]=*buf=='i'; if(yukvars[i].vartype==ick_HYBRID) ick_hyforget[yukvars[i].intername]=*buf=='i'; } } } if(temp) { if(*buf=='i') (void) puts("Variable ignored."); else (void) puts("Variable remembered."); break; } (void) puts("That variable is not in the program."); break; case '<': if(buf[1]!='.'&&buf[1]!=':') { (void) puts("You cannot set that sort of variable (if it exists at all)."); break; } temp = sscanf(buf+2,"%d",&templine); if(templine<1 || temp != 1) { (void) puts("Don't know which variable you mean."); break; } i=-1; temp=0; while(++i,!temp) { if(yukvars[i].vartype==YUKEND) break; if((buf[1]=='.'&&yukvars[i].vartype==ick_ONESPOT)|| (buf[1]==':'&&yukvars[i].vartype==ick_TWOSPOT)) { if(yukvars[i].extername==templine) { temp=1; if(yukvars[i].vartype==ick_ONESPOT) ick_onespots[yukvars[i].intername]=(ick_type16)ick_pin(); if(yukvars[i].vartype==ick_TWOSPOT) ick_twospots[yukvars[i].intername]=(ick_type32)ick_pin(); /* note that when debugging, you can set an ignored variable */ } } } if(temp) break; (void) puts("That variable is not in the program."); break; case 'g': temp = sscanf(buf+1,"%d",&templine); if(!templine || temp != 1) { (void) puts("Don't know which line you mean."); break; } breakpoints[0] = templine; yukloop = 1; /* This is implemented by incrementing all ABSTAIN counts, even the normally immutable ones on GIVE UP lines, setting a temporary breakpoint ([0]) on the line given, and running the program. When the breakpoint is hit singlestep will see that yukloop is set (its purpose is to cause the program to go back to the start when it reaches the end) and decrement all ABSTAIN counts, putting the commands back the way they were. We set an error breakpoint on this line in case the user is trying to jump to a line with no commands (although this debugger command is called 'g', would I dare to describe this as a GOTO?) */ i = -1; while(++i=80) ick_lose(IE811,emitlineno,(const char*)NULL); } else (void) puts("Don't know which line you mean."); break; case 'd': temp = sscanf(buf+1,"%d",&templine); if(templine && temp == 1) { printf("All breakpoints removed from line %d.\n",templine); i=nbreakpoints; while(i--) if(templine==breakpoints[i]) { memmove(breakpoints+i,breakpoints+i+1,sizeof(int)*(nbreakpoints-i)); nbreakpoints--; } } else (void) puts("Don't know which line you mean."); break; case 'm': temp = sscanf(buf+1,"%d",&templine); if(templine && temp == 1) { printf("Monitor set at line %d.\n",templine); monitors[nmonitors++]=templine; if(nmonitors>=80) ick_lose(IE811,emitlineno,(const char*)NULL); } else (void) puts("Don't know which line you mean."); break; case 'f': temp = sscanf(buf+1,"%d",&templine); if(templine && temp == 1) { printf("All monitors removed from line %d.\n",templine); i=nmonitors; while(i--) if(templine==monitors[i]) { memmove(monitors+i,monitors+i+1,sizeof(int)*(nmonitors-i)); nmonitors--; } } else (void) puts("Don't know which line you mean."); break; case 's': singlestep=1; writelines=1; keeplooping=0; break; case 't': singlestep=0; writelines=1; keeplooping=0; break; case 'u': temp = sscanf(buf+1,"%d",&templine); if(templine && temp == 1) { breakpoints[0]=templine; singlestep=0; writelines=0; keeplooping=0; } else (void) puts("Don't know which line you mean."); break; case 'e': temp = sscanf(buf+1,"%d",&templine); if(!templine || temp != 1) { (void) puts("Don't know which line you mean."); break; } tempcmd=-1; temp=0; i=0; while(++tempcmd=yuklines) templine=yuklines-22; if(templine<1) templine=1; i=templine; while(i9) buf[temp++]='!'; else buf[temp++]='0'+(char)ick_abstained[tempcmd]; if(temp==6) break; } } printf("(A%s)%5d:\t%s\n",buf,i,textlines[i]); i++; } break; case '*': tempcharp=ick_findandtestopen("COPYING.txt",globalargv[1], "r",globalargv[2]); if(tempcharp != NULL) { #ifndef HAVE_SNPRINTF (void) sprintf(copyloc,"more < %s",tempcharp); #else (void) snprintf(copyloc,sizeof copyloc,"more < %s",tempcharp); #endif if (system(copyloc) != 0) /* display the GNU GPL copyright */ (void) puts("Your system is more confused."); } else (void) puts("Couldn't find license file. See the file COPYING.txt that\n" "came with your C-INTERCAL distribution."); break; default: (void) puts("Not sure what you mean. Try typing ?."); break; } } while(keeplooping); } } firstrun=0; } intercal-0.29/src/lexer.l0000644000175000017500000003442311443403272015212 0ustar brooniebroonie%e 2000 %p 4000 %n 1000 %{ /* the directives above are for Solaris lex, and will be ignored by * flex */ /* * 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 "config.h" #include #include #include #include #include "ick.h" #include "parser.h" #include "ick_lose.h" /*#undef wchar_t*/ /*#define wchar_t unsigned char*/ #ifndef yywrap static int yywrap(void) { return 1; } #endif /* yywrap */ int iyylineno = 1; #ifdef MAIN YYSTYPE yylval; #endif /* MAIN */ char **textlines = NULL; int textlinecount = 0; int politesse = 0; int stbeginline = 0; /* AIS: Sort out a grammar near-ambiguity */ unsigned long sparkearsstack[SENESTMAX] = {0}; int sparkearslev = 0; /* AIS: Some symbols are ambiguous between C-INTERCAL and CLC-INTERCAL: Symbol C-INTERCAL CLC-INTERCAL NOSPOT _ @ WHIRL @ ? XOR ? yen, or bookworm (bookworm's also C-INTERCAL legal) By default, the C-INTERCAL meanings are used; the extern variable clclex causes CLC-INTERCAL interpretations to be put on the ambiguous symbols. Otherwise, mixing syntaxes freely is allowed. */ extern int clclex; #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(const char *text); void yyerror(const char *errtype); #define SETLINENO \ {if (stbeginline == 0) stbeginline = iyylineno;\ else if (stbeginline < 0) stbeginline = 0;} /* AIS: Keep track of the spark/ears situation */ #define STACKSPARKEARS(a) \ if (sparkearslev+1>=SENESTMAX*32) ick_lose(IE281, iyylineno, (char*) NULL); \ sparkearslev++; sparkearsstack[sparkearslev/32]<<=1; \ sparkearsstack[sparkearslev/32]+=a #define CLEARSPARKEARSTACK {int i=SENESTMAX; \ while(i--) sparkearsstack[i] = 0;} \ sparkearslev = 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; static bool eolflag = false; if ((size_t)(lineptr - linebuf) > sizeof linebuf) ick_lose(IE666, iyylineno, (char *)NULL); 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; char c_char; size_t dummy; /*fprintf(stderr,"about to fgetc(\045p)",(void*)fp);*/ c_char=0; /* AIS */ dummy = fread(&c_char,1,1,fp); /* AIS: ignore the first \r in a row to deal with DOS newlines. The second in a row is definitely an error, though, and will be caught later on. */ if(c_char=='\r') dummy = fread(&c_char,1,1,fp); c = c_char; if(feof(fp)) c=EOF; if(!eolflag && c == EOF) c = '\n'; /*fprintf(stderr,"getc input a character: %c\n",c);*/ if (feof(yyin)) { *lineptr = '\0'; if(eolflag) return(EOF); if(c=='\0' || c==EOF) c='\n'; } eolflag = false; 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 (iyylineno >= textlinecount) { textlinecount += ALLOC_CHUNK; if (textlines) textlines = realloc(textlines, textlinecount * sizeof(char*)); else textlines = malloc(textlinecount * sizeof(char*)); if (!textlines) ick_lose(IE666, iyylineno, (char *)NULL); } textlines[iyylineno] = malloc(1 + strlen(linebuf)); if (!textlines[iyylineno]) ick_lose(IE666, iyylineno, (char *)NULL); strcpy(textlines[iyylineno], linebuf); iyylineno++; eolflag=true; return('\n'); } else { 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]* I [A-Z] %% {D} {yylval.numval = myatoi(yytext); return(NUMBER);} \_ {return(NOSPOT);} \. {return(ick_ONESPOT);} \: {return(ick_TWOSPOT);} \, {return(ick_TAIL);} \; {return(ick_HYBRID);} \# {return(MESH);} \xBD | "c^H/" | "c^H|" {return(MINGLE); /* AIS: CLC-INTERCAL ick_mingle symbols. The \xBD is ISO-8859-1 for cent. */} \$ | \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);} \/ {return(SLAT); /* AIS: Operand overloading */} \\ {return(BACKSLAT); /* ditto */} \& {yylval.numval = AND; return(UNARY);} V {yylval.numval = OR; return(UNARY);} \xA5 | \xBE | "V^H-" | \xE2\x88\x80 {yylval.numval = XOR; return(UNARY); /* AIS: CLC-INTERCAL uses \xBE, ISO-8859-1 for yen; for some reason, \xA5 is what was detected by the compiler during my tests, so that's here too */} \? {if(clclex) yylval.numval = WHIRL; else yylval.numval = XOR; return(UNARY); /* AIS: ? is a unary operator in both C-INTERCAL and CLC-INTERCAL, but with different meanings. */} \| | \^ {yylval.numval = FIN; return(UNARY); /* AIS: | is CLC */} @ {if(clclex) return(NOSPOT); /* AIS: a C/CLC ambiguity */ else {yylval.numval = WHIRL; return(UNARY);}} [2-5]{W}@ {yylval.numval = WHIRL + myatoi(yytext) - 1; return(UNARY);} \' {char temp = sparkearsstack[sparkearslev/32]&1; STACKSPARKEARS(0); /* AIS: I added all mentions of STACKSPARKEARS, OPEN\(SPARK\|EARS\), CLOSE\(SPARK\|EARS\), and CLEARSPARKEARSTACK */ return(temp?OPENSPARK:CLOSESPARK);} \" {char temp = sparkearsstack[sparkearslev/32]&1; STACKSPARKEARS(1); return(temp?CLOSEEARS:OPENEARS);} \({W}{D}\) {SETLINENO; yylval.numval = myatoi(yytext); return(LABEL);} DO {SETLINENO; CLEARSPARKEARSTACK; return(DO);} FAC {SETLINENO; CLEARSPARKEARSTACK; return(DO);} PLEASE {SETLINENO; CLEARSPARKEARSTACK; politesse++; return(DO);} PLACET {SETLINENO; CLEARSPARKEARSTACK; politesse++; return(DO);} PLEASE{W}DO {SETLINENO; CLEARSPARKEARSTACK; politesse++; return(DO);} PLACET{W}FACERE {SETLINENO; CLEARSPARKEARSTACK; politesse++; return(DO);} MAYBE {SETLINENO; CLEARSPARKEARSTACK; return(MAYBE);} MAYBE{W}DO {SETLINENO; CLEARSPARKEARSTACK; return(MAYBE);} MAYBE{W}PLEASE {SETLINENO; CLEARSPARKEARSTACK; politesse++; return(MAYBE);} MAYBE{W}PLEASE{W}DO {SETLINENO; CLEARSPARKEARSTACK; politesse++; return(MAYBE); /* AIS: I added all the MAYBE cases. It seems that MAYBE has no simple Latin synonym. */} NOT {return(NOT);} N\'T {return(NOT);} NON {return(NOT);} \xAA {return(NOT); /* AIS: CLC-INTERCAL again, this time it's ISO-8859-1 for the logical NOT symbol... */} \xAC {return(NOT); /* ... but my computer translates it to \xAC */} ONCE {return(ONCE);} QUONDAM {return(ONCE);} AGAIN {return(AGAIN);} ITERUM {return(AGAIN);} \%{W}{D} {yylval.numval = myatoi(yytext); if (yylval.numval && yylval.numval < 100) return(OHOHSEVEN); else ick_lose(IE017, iyylineno, (char *)NULL);} SUB {return(SUB);} MULTIPLICATUS{W}A | BY {return(BY);} \<- {return(GETS);} CALCULANDUM | CALCULATING {yylval.numval = GETS; 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 | ABSTAIN {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);} COMMEMERO | COMMENTS | COMMENTING | COMMENT {yylval.numval = UNKNOWN; return(GERUND); /* AIS: An idea stolen from CLC-INTERCAL. The Latin means literally 'remind' or 'mention'. */} PIN {/* By AIS. I can't find a Latin translation for this. */ return(PIN);} PINNING {/* By AIS */ yylval.numval = PIN; return(GERUND);} DEINDERE{W}A{W}\({W}{D}\) | NEXT{W}FROM{W}\({W}{D}\) {/* AIS */ yylval.numval = myatoi(yytext); return(NEXTFROMLABEL);} DEINDERE{W}A | NEXT{W}FROM {/* AIS: 'next' is not a verb, so the Latin is invented */ return(NEXTFROMEXPR);} DEINDENDUM | NEXTING{W}FROM {/* AIS */ yylval.numval = NEXTFROMLABEL; return(GERUND);} ADVENIRE{W}DE{W}\({W}{D}\) | COME{W}FROM{W}\({W}{D}\) {/* AIS */ yylval.numval = myatoi(yytext); return(COME_FROM);} ADVENIRE{W}DE | COME{W}FROM {/* AIS */ return(COMPUCOME);} ADVENENDUM | COMING{W}FROM {yylval.numval = COME_FROM; return(GERUND);} DEINDE | NEXT {stbeginline = 0; return(NEXT);} PROXIMANDUM | NEXTING {yylval.numval = NEXT; return(GERUND);} FROM {return(FROM); /* AIS: Latin is 'A', which confuses the rest of the parser */} CONCEDERE | DESPERARE | GIVE{W}UP {return(GIVE_UP);} CONOR{W}ITERUM | TRY{W}AGAIN {return(TRY_AGAIN);} WHILE {return(WHILE); /* AIS. Latin for this is needed. */} WHILING | LOOPING {yylval.numval = WHILE; return(GERUND);} TRYING{W}AGAIN {yylval.numval = TRY_AGAIN; return(GERUND);} GO{W}BACK | REDIRE {return(GO_BACK);} GOING{W}BACK | REDENDUM {yylval.numval = GO_BACK; return(GERUND);} GO{W}AHEAD | GRASSOR {return(GO_AHEAD);} GOING{W}AHEAD {yylval.numval = GO_AHEAD; return(GERUND); /* AIS: I'm having a few deponent troubles with the Latin, so there are no Latin gerunds around here. Besides, the Latin 'gerunds' look somewhat like gerundives to me, but that's purely based on memory so I may be wrong. */} CREATE{W}\({W}{D}\) | CONFICE{W}\({W}{D}\) {yylval.numval = myatoi(yytext); return(CREATE);} CREATE | CONFICE {return(COMPUCREATE);} CREATING | CREATION | CONFICENDUM {yylval.numval = CREATE; return(GERUND);} \+ {return(INTERSECTION);} {W} ; {I} {/* AIS */ yylval.numval = *yytext; return(UNKNOWNID);} .\^H. {/* AIS */ yylval.numval = yytext[0]*256 + yytext[3]; if(yytext[0] > yytext[3]) yylval.numval = yytext[0] + yytext[3]*256; return(BADCHAR);} . {yylval.numval = yytext[0]; /* AIS: The line below for debug */ if(yydebug) fprintf(stdout, "yylex: bad char %#x\n",(unsigned char)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(const char *text) /* AIS */ { #define MAXTEXT 100 static char buf[MAXTEXT]; static char thinbuf[MAXTEXT]; char* bp; char* tp; register int i; for(buf[i = 0] = '\0';*text && i < MAXTEXT;text++) { if(isdigit(*text)) { buf[i++] = *text; } } buf[i] = '\0'; bp=buf; tp=thinbuf; while(((*tp++=*bp++))); /* thinbuf code added by an AIS in case we want to work with wchar_t; the extra brackets tell GCC that this is intended and not a mistaken assignment */ return atoi(thinbuf); } void yyerror(const char *errtype) { #ifdef MAIN (void) printf("lextest: lexer error: %s.\n", errtype); #else /* MAIN */ (void) errtype; #endif /* MAIN */ } #ifdef MAIN int ick_main(void) { int t; while ((t = yylex()) > 0) { (void) printf("%03d %09d\n", t, yylval.numval); yylval.numval = 0; } return 0; } #endif /* MAIN */ intercal-0.29/src/cesspool.c0000644000175000017500000006607111443404360015714 0ustar brooniebroonie/***************************************************************************** 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 #include #include #include #include "config.h" #ifdef HAVE_STDARG_H #include #else #include #endif #include "sizes.h" /* AIS: To avoid a separate overloaded/nonoverloaded library, we import the overloading defines here and ignore them if we don't need them. */ #define MULTITHREAD 0 #define OVEROPUSED 1 #include "abcess.h" #include "ick_lose.h" #include "numerals.c" /* AIS: because BUFSIZ could theoretically be too large for an int... */ #if BUFSIZ < INT_MAX #define INTBUFSIZ (int)BUFSIZ #else #define INTBUFSIZ (int)INT_MAX #endif /* and likewise, so that we can compare things to INT_MAX */ #ifndef min #define min(x,y) ((x)>(y)?(y):(x)) #endif /* and likewise, define SIZE_MAX */ #ifndef SIZE_MAX #ifdef ULLONG_MAX #define SIZE_MAX (sizeof(unsigned short )==sizeof(size_t)?(size_t) USHRT_MAX : \ sizeof(unsigned int )==sizeof(size_t)?(size_t) UINT_MAX : \ sizeof(unsigned long )==sizeof(size_t)?(size_t) ULONG_MAX : \ sizeof(unsigned long long)==sizeof(size_t)?(size_t)ULLONG_MAX : 0) #else #define SIZE_MAX (sizeof(unsigned short )==sizeof(size_t)?(size_t) USHRT_MAX : \ sizeof(unsigned int )==sizeof(size_t)?(size_t) UINT_MAX : \ sizeof(unsigned long )==sizeof(size_t)?(size_t) ULONG_MAX : 0) #endif #endif /* AIS: These will be set to stdin/stdout at the first opportunity, which is not necessarily here. The annotations are to tell splint that we know what we're doing here with the assignments; the set to stdin/stdout will be done whenever it's necessary. */ /*@null@*/ FILE* ick_cesspoolin =0; /*@null@*/ FILE* ick_cesspoolout=0; /* AIS: To keep ld happy. This shouldn't ever actually get used, but * give it a sane value just in case it does. (This is referenced by * clc-cset.c, but due to the linking-in of the character sets * themselves the reference should never be used.) */ /*@observer@*/ /*@dependent@*/ const char* ick_datadir="."; /********************************************************************** * * The following functions manipulate the nexting stack * *********************************************************************/ unsigned* ick_next; /* AIS: now allocated by ick-wrap.c */ /*@null@*/ jmp_buf* ick_next_jmpbufs = NULL; /* AIS: for ick_ec, if needed */ int ick_nextindex = 0; static int ick_clcsem = 0; /* AIS */ void ick_pushnext(unsigned n) { if (ick_nextindex < ick_MAXNEXT) ick_next[ick_nextindex++] = n; else ick_lose(IE123, ick_lineno, (const char *)NULL); } unsigned int ick_popnext(unsigned int n) { ick_nextindex -= n; if (ick_nextindex < 0) { ick_nextindex = 0; return (unsigned int)-1; } return ick_next[ick_nextindex]; } /* AIS: This is not the ick_resume in ick_ec.h, which is a macro and therefore technically speaking doesn't clash with this function as the header file ick_ec.h isn't included. */ unsigned int ick_resume(unsigned int n) { if (n == 0) { ick_lose(IE621, ick_lineno, (const char *)NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } else if ((n = ick_popnext(n)) == (unsigned int)-1) { ick_lose(IE632, ick_lineno, (const char *)NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } return(n); } /********************************************************************** * * The following functions implement the INTERCAL I/O model * *********************************************************************/ unsigned int ick_pin(void) { char buf[INTBUFSIZ], *cp; unsigned int result = 0; size_t n; assert(buf != NULL); /* AIS: splint seems unable of figuring this out for itself */ if(!ick_cesspoolin) ick_cesspoolin=stdin; /* AIS */ if (fgets(buf, INTBUFSIZ, ick_cesspoolin) == (char *)NULL) ick_lose(IE562, ick_lineno, (const char *)NULL); n = strlen(buf) - 1; if (n > 0 && buf[n-1] == '\r') --n; buf[n] = '\0'; if(ick_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; const numeral *np; for (np = ick_numerals; np < ick_numerals + sizeof(ick_numerals)/sizeof(numeral); np++) if (strcmp(np->name, cp) == 0) { digit = np->value; break; } if (digit == -1) ick_lose(IE579, ick_lineno, cp); if (result < 429496729 || (result == 429496729 && digit < 6)) result = result * 10 + digit; else ick_lose(IE533, ick_lineno, (const char *)NULL); } } if (!n) ick_lose(IE562, ick_lineno, (const char *)NULL); if (result > (unsigned int)ick_Max_large) ick_lose(IE533, ick_lineno, (const char *)NULL); return(result); } /********************************************************************** * * Butchered Roman ick_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 ick_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 ick_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, /*@out@*/ 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 const 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 const 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 = (int)(val % 10); for (j = ick_br_trans[digitval][0]; j > 0; j--) { /* printf("In j loop: %d %d\n", j, i); */ res[--i] = br_equiv[digitsig][ick_br_trans[digitval][j]]; ovb[i] = br_overbar[digitsig][ick_br_trans[digitval][j]]; } val = val / 10; } j = i; while ((*result++ = ovb[j++]) != '\0') continue; *--result = '\n'; j = i; while ((*++result = res[j++]) != '\0') continue; /* Final newline will be added by puts. *result++ = '\n'; */ *result = '\0'; } } void ick_clockface(bool mode) /* enable or disable ick_clockface mode (output IIII instead of IV) */ { if (mode) { /* ick_clockface mode */ ick_br_trans[4][0] = 4; ick_br_trans[4][1] = 0; ick_br_trans[4][2] = 0; } else { /* normal mode */ ick_br_trans[4][0] = 2; ick_br_trans[4][1] = 1; ick_br_trans[4][2] = 2; } } void ick_setclcsemantics(bool mode) /* AIS: CLC-INTERCAL semantics mode? */ { ick_clcsem=mode; } void ick_pout(unsigned int val) /* output in `butchered' Roman ick_numerals; see manual, part 4.4.13 */ { char result[2*MAXROMANS+1]; if(!ick_cesspoolout) ick_cesspoolout=stdout; /* AIS */ if(ick_wimp_mode) { (void) fprintf(ick_cesspoolout,"%u\n",val); } else { butcher(val, result); (void) fprintf(ick_cesspoolout,"%s\n",result); } (void) fflush(ick_cesspoolout); } /********************************************************************** * * AIS: CLC-INTERCAL bitwise I/O, only used in CLC-INTERCAL semantics * mode. The I/O is done in extended Baudot for a tail ick_array, or in * mingled form for a hybrid ick_array; for the Baudot, we rely on * clc-cset.c and on the Baudot and Latin-1 character sets that are * linked to libick.a (or libickmt.a), so the final executable doesn't * reference the compiler's libraries. clc-cset.c is designed to * handle this all transparently, though, so we don't have to worry * about the details. I wrote the next two functions. * **********************************************************************/ /* AIS: From clc-cset.c */ extern int ick_clc_cset_convert(const char* in, /*@partial@*/ char* out, const char* incset, const char* outcset, int padstyle, size_t outsize, /*@null@*/ FILE* errsto); static void clcbinin(unsigned int type, ick_array *a, bool forget) { size_t i; int ti; char* buf, *tempcp; /* Allocating one byte per element in the ick_array must be enough, * because the Baudot version cannot possibly be shorter than the * original Latin-1, plus one for the terminating NUL. There is one * potential problem, which is that fgets takes an int for the * number of bytes to read, so we cap the number of bytes to read * at INT_MAX and hope that's enough. */ i=a->dims[0]; /* we already know that there's 1 dim only */ if(SIZE_MAX/6-2<=a->dims[0]) ick_lose(IE252, ick_lineno, (const char*)NULL); /* size is too large */ if(!i) i=1; buf=malloc(i+1); if(!buf) ick_lose(IE252, ick_lineno, (const char*)NULL); if(!ick_cesspoolin) ick_cesspoolin=stdin; if(!fgets(buf,(int)(min(a->dims[0],(size_t)INT_MAX)),ick_cesspoolin)) strcpy(buf,"\n"); /* EOF inputs the null string in CLC-INTERCAL */ tempcp=strrchr(buf,'\n'); /* still working in ASCII at this point */ if(!tempcp) /* input too long for the ick_array is an error */ { free(buf); ick_lose(IE241, ick_lineno, (const char*)NULL); } *tempcp='\0'; /* chomp the final newline */ tempcp=malloc(6*i+12); /* to be on the safe side, even though * Baudot doesn't use 16-byte chars */ if(!tempcp) ick_lose(IE252, ick_lineno, (const char*)NULL); /* Zero the ick_array now. */ i=a->dims[0]; if(!forget) while(i--) if(type==ick_TAIL) a->data.tail[i]=0; else a->data.hybrid[i]=0; ti=ick_clc_cset_convert(buf,tempcp,"latin1","baudot",2,6*a->dims[0]+12,(FILE*)0); /* Negative ti ought to be impossible here; check anyway, and cause * an internal error if it has happened. */ if(ti<0) ick_lose(IE778, ick_lineno, (const char*)NULL); i=(size_t)ti; if(i>a->dims[0]) ick_lose(IE241, ick_lineno, (const char*)0); if(!forget) while(i--) if(type==ick_TAIL) a->data.tail[i]=(ick_type16)tempcp[i]+ (ick_type16)((rand()%256)*256); else a->data.hybrid[i]=(ick_type32)tempcp[i]+ (ick_type32)((rand()%256)*256); free(tempcp); free(buf); } static void clcbinout(unsigned int type, const ick_array* a) { size_t i; int ti; char* buf, *tempcp; if(SIZE_MAX/6-2<=a->dims[0]) ick_lose(IE252, ick_lineno, (const char*)NULL); /* size is too large */ buf=malloc(a->dims[0]+1); if(!buf) ick_lose(IE252, ick_lineno, (const char*) NULL); i=0; tempcp=buf; while(idims[0]) { /* Values above 31 are invalid in Baudot, so cap them at 33 to avoid integer wraparound trouble. */ if(type==ick_TAIL) *tempcp=(char)min(33,a->data.tail[i]); else *tempcp=(char)min(33,a->data.hybrid[i]); i++; if(*tempcp!='\0') tempcp++; /* NULs are ignored for some reason, but * that's the behaviour the CLC-INTERCAL * specs specify */ } *tempcp='\0'; /* tempcp is definitely overkill here, but the *6+6 rule is being * obeyed because that way the code is robust against any future * changes in character sets. */ tempcp=malloc(a->dims[0]*6+12); if(!tempcp) ick_lose(IE252, ick_lineno, (const char*) NULL); ti=ick_clc_cset_convert(buf,tempcp,"baudot","latin1",0,6*a->dims[0]+12,(FILE*)0); if(ti<0) ick_lose(IE778, ick_lineno, (const char*)NULL); i=(size_t)ti; tempcp[i]='\0'; /* CLC-INTERCAL bails out on invalid characters. C-INTERCAL uses * instead the behaviour of replacing them with character code 26. * (This is actually the purpose of character code 26 in ASCII, I * think, although this is derived from memory; I don't know of any * other system that uses it for this purpose, though, and the * ability to confuse Windows with it is worth what might be lost * through standards compliance, because Windows nonstandardly * treats it as an EOF character.) */ while(i--) if(tempcp[i] == '\0') tempcp[i]='\x1a'; if(!ick_cesspoolout) ick_cesspoolout=stdout; fprintf(ick_cesspoolout,"%s\n",tempcp); (void) fflush(ick_cesspoolout); free(tempcp); free(buf); } /********************************************************************** * * 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 ick_binin(unsigned int type, ick_array *a, bool forget) { static int lastin = 0; int c, v; size_t i; if (a->rank != 1) ick_lose(IE241, ick_lineno, (const char *)NULL); if(!ick_cesspoolin) ick_cesspoolin=stdin; /* AIS */ if(ick_clcsem) {clcbinin(type, a, forget); return;} /* AIS */ for (i = 0 ; i < a->dims[0] ; i++) { v = ((c=fgetc(ick_cesspoolin)) == EOF) ? 256 : ((unsigned)c - lastin) % 256; lastin = c; if (!forget) { if (type == ick_TAIL) a->data.tail[i] = (ick_type16) v; else a->data.hybrid[i] = (ick_type32) v; } } } void ick_binout(unsigned int type, const ick_array *a) { static unsigned int lastout = 0; unsigned int c; size_t i; if (a->rank != 1) ick_lose(IE241, ick_lineno, (const char *)NULL); if(!ick_cesspoolout) ick_cesspoolout=stdout; /* AIS */ if(ick_clcsem) {clcbinout(type, a); return;} /* AIS */ for (i = 0 ; i < a->dims[0] ; i++) { if (type == ick_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; (void) fputc((int)c,ick_cesspoolout); if (c == 10 /* \n in INTERCAL */ || /* AIS */ ick_instapipe) (void) fflush(ick_cesspoolout); } } /********************************************************************** * * The following assignment function performs IGNORE and type checks * *********************************************************************/ unsigned int ick_assign(char *dest, unsigned int type, bool forget, unsigned int value) { unsigned int retval = 0; if (type == ick_ONESPOT || type == ick_TAIL) { if (value > (unsigned int)ick_Max_small) ick_lose(IE275, ick_lineno, (const char *)NULL); if (forget) retval = value; else { retval = *(ick_type16*)dest; *(ick_type16*)dest = (ick_type16) value; } } else if (type == ick_TWOSPOT || type == ick_HYBRID) { if (forget) retval = value; else { retval = *(ick_type32*)dest; *(ick_type32*)dest = value; } } return retval; } /********************************************************************** * * The following functions implement the INTERCAL ick_array model * If HAVE_STDARG_H is defined, stdarg is used, otherwise varargs. * *********************************************************************/ #ifdef HAVE_STDARG_H /*@dependent@*/ void *ick_aref(unsigned int type, ...) #else /*@dependent@*/ void *ick_aref(va_alist) va_dcl #endif /* return a pointer to the ick_array location specified by args */ { #ifndef HAVE_STDARG_H unsigned int type; #endif ick_array *a; unsigned int v; va_list ap; size_t address = 0; unsigned int i; #ifdef HAVE_STDARG_H va_start(ap, type); #else va_start(ap); type = va_arg(ap, unsigned int); #endif a = va_arg(ap, ick_array*); if (va_arg(ap, unsigned int) != a->rank) ick_lose(IE241, ick_lineno, (const char *)NULL); for (i = 0 ; i < a->rank ; i++) { v = va_arg(ap, unsigned int); if (v == 0 || (size_t)v > a->dims[i]) ick_lose(IE241, ick_lineno, (const char *)NULL); address = address * a->dims[i] + v - 1; } va_end(ap); if (type == ick_TAIL) return (void*)&(a->data.tail[address]); else return (void*)&(a->data.hybrid[address]); } #ifdef HAVE_STDARG_H void ick_resize(unsigned int type, ...) #else void ick_resize(va_alist) va_dcl #endif /* ick_resize an ick_array to the given shape */ { #ifndef HAVE_STDARG_H unsigned int type; #endif ick_array *a; bool forget; unsigned int i, r; size_t v; va_list ap; int prod = 1; #ifdef HAVE_STDARG_H va_start(ap, type); #else va_start(ap); type = va_arg(ap, unsigned int); #endif a = va_arg(ap, ick_array*); #ifdef BOOL_VARARGS_BROKEN forget = (bool)va_arg(ap, int); #else forget = va_arg(ap, bool); #endif /* AIS: a->dims is no longer initialised. So initialise it here if it isn't already initialised, with an annotation to explain that we aren't freeing the old pointer (because it was never malloced in the first place and is probably invalid anyway.) */ /*@-mustfreeonly@*/ if (!a->rank) a->dims = 0; /*@-mustfreeonly@*/ r = va_arg(ap, unsigned int); if (!forget) { a->rank = r; if (a->dims) free((char*)a->dims); a->dims = malloc(a->rank * sizeof(*(a->dims))); if (a->dims == NULL) ick_lose(IE241, ick_lineno, (const char *)NULL); } for (i = 0 ; i < r ; i++) { v = va_arg(ap, size_t); if (v == 0) ick_lose(IE240, ick_lineno, (const char *)NULL); if (!forget) { assert(a->dims != NULL); /* AIS: it isn't, because !forget, but splint doesn't know that */ a->dims[i] = v; prod *= v; } } if (!forget) { if (type == ick_TAIL) { if (a->data.tail) free((char *)a->data.tail); a->data.tail = (ick_type16*)malloc(prod * sizeof(ick_type16)); if (a->data.tail == NULL) ick_lose(IE241, ick_lineno, (const char *)NULL); } else { if (a->data.hybrid) free((char *)a->data.hybrid); a->data.hybrid = (ick_type32*)malloc(prod * sizeof(ick_type32)); if (a->data.hybrid == NULL) ick_lose(IE241, ick_lineno, (const char *)NULL); } } va_end(ap); } /********************************************************************** * * The following functions implement save/retrieve * *********************************************************************/ /*@null@*/ ick_stashbox *ick_first; /* AIS: made non-static so it can be seen by unravel.c */ void ick_stashinit(void) { ick_first = NULL; } static /*@null@*/ ick_stashbox *fetch(unsigned int type, unsigned int index) /* find a stashed variable in the save stack and extract it */ { ick_stashbox **pp = &ick_first, *sp = ick_first; while (sp != NULL && (sp->type != type || sp->index != index)) { pp = &sp->ick_next; sp = sp->ick_next; } if (sp) *pp = sp->ick_next; /* The annotation here is because Splint can't figure out that ick_first can be modified via pp, and because this function is the place where storage marked 'dependent' is initialised and deinitialised. */ /*@-globstate@*/ /*@-dependenttrans@*/ return (sp); /*@=globstate@*/ /*@=dependenttrans@*/ } void ick_stash(unsigned int type, unsigned int index, void *from, ick_overop* oo) /* stash away the variable's value */ { /*@-nullassign@*/ ick_overop dummyoo; /*@=nullassign@*/ /* create a new ick_stashbox and push it onto the stack */ ick_stashbox *sp; dummyoo.get = (ick_type32 (*)(ick_type32))NULL; dummyoo.set = (void (*)(ick_type32, void(*)()))NULL; sp = (ick_stashbox*)malloc(sizeof(ick_stashbox)); if (sp == NULL) ick_lose(IE222, ick_lineno, (const char *)NULL); sp->ick_next = ick_first; ick_first = sp; /* store the variable in it */ ick_first->type = type; ick_first->index = index; if(oo) ick_first->overloadinfo=oo[index]; /* AIS */ else ick_first->overloadinfo=dummyoo; /* AIS */ if (type == ick_ONESPOT) { memcpy(&ick_first->save.onespot, from, sizeof(ick_type16)); } else if (type == ick_TWOSPOT) memcpy(&ick_first->save.twospot, from, sizeof(ick_type32)); else if (type == ick_TAIL || type == ick_HYBRID) { ick_array *a = (ick_array*)from; int prod; unsigned int i; ick_first->save.a = (ick_array*)malloc(sizeof(ick_array)); if (ick_first->save.a == NULL) ick_lose(IE222, ick_lineno, (const char *)NULL); ick_first->save.a->rank = a->rank; ick_first->save.a->dims = malloc(a->rank * sizeof(*(ick_first->save.a->dims))); if (ick_first->save.a->dims == NULL) ick_lose(IE222, ick_lineno, (const char *)NULL); memcpy(ick_first->save.a->dims, a->dims, a->rank * sizeof(*(a->dims))); prod = a->rank ? 1 : 0; for (i = 0 ; i < a->rank ; i++) { prod *= a->dims[i]; } if (type == ick_TAIL) { ick_first->save.a->data.tail = (ick_type16*)malloc(prod * sizeof(ick_type16)); if (ick_first->save.a->data.tail == NULL) ick_lose(IE222, ick_lineno, (const char *)NULL); memcpy(ick_first->save.a->data.tail, a->data.tail, prod * sizeof(ick_type16)); } else { ick_first->save.a->data.hybrid = (ick_type32*)malloc(prod * sizeof(ick_type32)); if (ick_first->save.a->data.hybrid == NULL) ick_lose(IE222, ick_lineno, (const char *)NULL); memcpy(ick_first->save.a->data.hybrid, a->data.hybrid, prod * sizeof(ick_type32)); } } return; } void ick_retrieve(void *to, unsigned int type, unsigned int index, bool forget, ick_overop* oo) /* restore the value of a variable from the save stack */ { ick_stashbox *sp; if ((sp = fetch(type, index)) == (ick_stashbox *)NULL) ick_lose(IE436, ick_lineno, (const char *)NULL); else if (!forget) { if(oo) oo[index]=sp->overloadinfo; /* AIS */ if (type == ick_ONESPOT) memcpy(to, (const char *)&sp->save.onespot, sizeof(ick_type16)); else if (type == ick_TWOSPOT) memcpy(to, (const char *)&sp->save.twospot, sizeof(ick_type32)); else if (type == ick_TAIL || type == ick_HYBRID) { ick_array *a = (ick_array*)to; /*@-branchstate@*/ /* it's a union, so one valid is correct */ if (a->rank) { free(a->dims); if (type == ick_TAIL) free(a->data.tail); else free(a->data.hybrid); memcpy(to, (const char*)sp->save.a, sizeof(ick_array)); } /*@=branchstate@*/ /* AIS: there isn't a memory leak here, because we memcpyd the pointers elsewhere and so they are yet accessible. You can't expect Splint to figure out what's going on there, though, thus the annotations. */ /*@-compdestroy@*/ free(sp->save.a); /*@=compdestroy@*/ } } else if (type == ick_TAIL || type == ick_HYBRID) { free(sp->save.a->dims); if (type == ick_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 ick_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 */ } /********************************************************************** * * AIS: This function is called when two COME FROMs reference the same * line at runtime. ick_multicome0 is used in a non-multithread * program; it produces an error. For multicome1, see unravel.c. * *********************************************************************/ int ick_multicome0(int errlineno, jmp_buf pc) { /*@-noeffect@*/ (void) pc; /* it's ignored by this function */ /*@=noeffect@*/ ick_lose(IE555, errlineno, (const char *) NULL); /* this line number is quite possibly going to be wildly inaccurate */ /*@-unreachable@*/ return 0; /*@=unreachable@*/ } /********************************************************************** * * AIS: The next two functions are mine, and handle CREATE statements. * **********************************************************************/ struct ick_jictype { /*@observer@*/ const char* sig; /* a shallow copy of a constant string */ unsigned long target; /*@null@*/ /*@only@*/ struct ick_jictype* next; }; /*@null@*/ /*@only@*/ static struct ick_jictype* jiclist = NULL; /* Return a jic entry that matches the requested signature exactly, creating one if there isn't one yet. */ static struct ick_jictype* jicextract(/*@observer@*/ const char* sig) { struct ick_jictype* jicptr = jiclist; while(jicptr) { if(strcmp(jicptr->sig,sig)==0) return jicptr; if(jicptr->next != NULL) jicptr = jicptr->next; else break; } if(!jicptr) { jiclist=malloc(sizeof *jiclist); jicptr=jiclist; } else { jicptr->next=malloc(sizeof *jiclist); jicptr=jicptr->next; } jicptr->next = NULL; jicptr->sig = sig; jicptr->target = 0; return jicptr; } void ick_registercreation(const char* sig, unsigned long target) { jicextract(sig)->target=target; } unsigned long ick_jicmatch(const char* sig) { return jicextract(sig)->target; } /* AIS: Used by the JIC code to error out when attempting to access an array */ ick_type32 ick_ieg277(ick_type32 ignored) { /*@-noeffect@*/ (void) ignored; /*@=noeffect@*/ ick_lose(IE277, ick_lineno, (const char*) NULL); } void ick_ies277(ick_type32 ignored, void(*ignored2)()) { /*@-noeffect@*/ (void) ignored; (void) ignored2; /*@=noeffect@*/ ick_lose(IE277, ick_lineno, (const char*) NULL); } /* cesspool.c ends here */ intercal-0.29/src/ebcdic.bin0000644000175000017500000000041711435477314015626 0ustar brooniebroonie256 1 hgfedcba  ¢.<(+!&]$*);¬-/¥|,%_>?:#@'="abcdefghijklmnopqr{[~stuvwxyz®^£©ABCDEFGHIJKLMNOPQR}STUVWXYZ0123456789intercal-0.29/src/uncommon.h0000644000175000017500000000163611443403272015722 0ustar brooniebroonie/* uncommon.h -- declarations for uncommon.c and C files linked to it */ #include "config.h" #include "ick_bool.h" /*@null@*/ /*@dependent@*/ extern FILE* ick_debfopen(/*@observer@*/ const char*, /*@observer@*/ const char*); /*@null@*/ /*@dependent@*/ extern FILE* ick_findandfopen(/*@observer@*/ const char*, /*@observer@*/ const char*, /*@observer@*/ const char*, /*@observer@*/ const char*); /*@observer@*/ /*@null@*/ extern const char* ick_findandtestopen(/*@observer@*/ const char*, /*@observer@*/ const char*, /*@observer@*/ const char*, /*@observer@*/ const char*); /*@null@*/ /*@dependent@*/ extern FILE* ick_findandfreopen(/*@observer@*/ const char*, /*@observer@*/ const char*, /*@observer@*/ const char*, /*@observer@*/ const char*, FILE*); extern int ick_snprintf_or_die(/*@out@*/ char *str, size_t size, /*@observer@*/ const char *format, ...) #ifdef __GNUC__ __attribute__ ((format(printf, 3, 4))) #endif ; intercal-0.29/src/yuk.h0000644000175000017500000001110011443403052014656 0ustar brooniebroonie/* yuk.h - header file for yuk.c and debugging versions of ick-wrap.c */ /* Copyright (C) Alex Smith 2006. See yuk.c for copyright conditions. This file is GPL'd, and so can be freely redistributed but has absolutely no warranty. */ #define YUK(t,u) yukline(t,u) #define YUKTERM yukterm() #define YUKEND 5 /*@-exportlocal@*/ /* because these are used by generated programs */ extern void yukline(int,int); extern void yukterm(void); extern int ick_abstained[]; extern int yukopts; extern int ick_lineno; extern int yuklines; extern int yukcommands; /*@-incondefs@*/ /* because it's a different textlines to the one in ick.h */ extern char *textlines[]; /*@=incondefs@*/ extern int lineofaboff[]; extern char *yukexplain[]; extern int yukloop; /*@=exportlocal@*/ /* Defines that change the functions used for profiling. */ /* Define the following to the timing function you want for profiling, or leave it undef to use the value computed by config.sh. */ #undef YPTIMERTYPE /* 0 to use clock(), 1 to use gettimeofday() and long, 2 to use gettimeofday() and long long, 3 to use gethrtime() 4 to use times(), 5 to use clock_gettime */ /* Note: On many systems, 0's resolution is too low to produce any output 1 and 2 produce the same output; use 2 if your system can handle long long because the overflow is dealt with more simply. 3 is a system-specific function. If there are more system-specific functions around that return more accurate times than the others used here, it would improve the profiler on those systems. According to the DJGPP documentation, it's impossible to get times with decent accuracy under DOS. DJGPP implements timer types 0, 1, and 2, so it will 'work' with the default value of 2, but the results you get will be basically meaningless as the base information can't be accurately obtained (the resolution is slightly worse than 50ms, which is far too slow for profiling). */ #ifndef YPTIMERTIME # ifdef HAVE_GETHRTIME # define YPTIMERTYPE 3 # else # if defined(HAVE_CLOCK_GETTIME) && SIZEOF_LONG_LONG_INT + 0 > 0 # define YPTIMERTYPE 5 # else # ifdef HAVE_GETTIMEOFDAY /* Allow for an erroneous blank value for SIZEOF_LONG_LONG_INT. */ # if SIZEOF_LONG_LONG_INT + 0 > 0 # define YPTIMERTYPE 2 # else # define YPTIMERTYPE 1 # endif # else # define YPTIMERTYPE 0 # endif # endif # endif #endif #if YPTIMERTYPE == 0 #define YPTIMERTFORMAT "lu" #define YPCOUNTERTFORMAT "lu" #define YPTIMERTFORMATD "6" YPTIMERTFORMAT #define YPTIMERSCALE CLOCKS_PER_SEC #define YPGETTIME clock() typedef unsigned long yptimer; typedef unsigned long ypcounter; #elif YPTIMERTYPE == 1 #define YPTIMERTFORMAT "lu" #define YPCOUNTERTFORMAT "lu" #define YPTIMERTFORMATD "6" YPTIMERTFORMAT #define YPTIMERSCALE 1000000LU #define YPGETTIME yukgettimeofday() typedef unsigned long yptimer; typedef unsigned long ypcounter; #elif YPTIMERTYPE == 2 #define YPTIMERTFORMAT "llu" #define YPCOUNTERTFORMAT "lu" #define YPTIMERTFORMATD "6" YPTIMERTFORMAT #define YPTIMERSCALE 1000000LU #define YPGETTIME yukgettimeofday() typedef unsigned long long yptimer; typedef unsigned long ypcounter; #elif YPTIMERTYPE == 3 #define YPTIMERTFORMAT "llu" #define YPCOUNTERTFORMAT "lu" #define YPTIMERTFORMATD "9" YPTIMERTFORMAT #define YPTIMERSCALE 1000000000LLU #define YPGETTIME gethrtime() typedef unsigned long long yptimer; typedef unsigned long ypcounter; #elif YPTIMERTYPE == 4 #define YPTIMERTFORMAT "lu" #define YPCOUNTERTFORMAT "lu" #define YPTIMERTFORMATD "6" YPTIMERTFORMAT #define YPTIMERSCALE CLK_TCK #define YPGETTIME yuktimes() typedef unsigned long yptimer; typedef unsigned long ypcounter; #elif YPTIMERTYPE == 5 #define YPTIMERTFORMAT "llu" #define YPCOUNTERTFORMAT "lu" #define YPTIMERTFORMATD "9" YPTIMERTFORMAT #define YPTIMERSCALE 1000000000LLU #define YPGETTIME yukclock_gettime() typedef unsigned long long yptimer; typedef unsigned long ypcounter; #else #error Invalid YPTIMERTYPE in yuk.h #endif /* YPTIMERTYPE cases */ extern yptimer ypexectime[]; extern ypcounter ypexecount[]; extern ypcounter ypabscount[]; typedef struct yukvar_tag { int vartype; int extername; int intername; } yukvar; extern yukvar yukvars[]; /*@-exportlocal@*/ /* this needs to be global */ extern char** globalargv; extern int globalargc; /*@=exportlocal@*/ /* Give our own definition of sig_atomic_t for systems that don't have it. char ought to be atomic, on most systems (especially as we don't touch anything but the bottom byte). */ #if SIZEOF_SIG_ATOMIC_T + 0 == 0 #undef sig_atomic_t typedef char sig_atomic_t; #endif intercal-0.29/src/oil.h0000644000175000017500000000673311443403272014655 0ustar brooniebroonie/* Header file for compiled OIL programs Does name mangling, defines macros Copyright (C) Alex Smith 2008 See oil.y for copyright conditions. */ #include "config.h" #include #include #include #include #include "sizes.h" #include "ick.h" #include "parser.h" #include "fiddle.h" #include "ick_lose.h" #include "feh.h" #define OPTING(x) \ if(optdebug == 2) \ { \ explexpr(optdebugnode,stderr); \ putc('\n',stderr); \ } \ if(optdebug == 3) \ { \ prexpr(optdebugnode,stderr,0); \ putc('\n',stderr); \ } \ if(optdebug) fprintf(stderr,"[%s]",#x); \ if(optdebug >= 2) putc('\n',stderr); \ opted = 1; #define MAYBENEWNODE(n) if(!(n)) (n)=newnode(); #define Base ick_Base #define Large_digits ick_Large_digits #define Max_large ick_Max_large #define Max_small ick_Max_small #define Small_digits ick_Small_digits #define and16 ick_and16 #define and32 ick_and32 #define aref ick_aref #define assign ick_assign #define binin ick_binin #define binout ick_binout #define bitencout ick_bitencout #define br_trans ick_br_trans #define cesspoolin ick_cesspoolin #define cesspoolout ick_cesspoolout #define checkforbugs ick_checkforbugs #define clc_cset_atari ick_clc_cset_atari #define clc_cset_baudot ick_clc_cset_baudot #define clc_cset_convert ick_clc_cset_convert #define clc_cset_ebcdic ick_clc_cset_ebcdic #define clc_cset_hardcoderead ick_clc_cset_hardcoderead #define clc_cset_latin1 ick_clc_cset_latin1 #define clc_cset_load ick_clc_cset_load #define clc_cset_ptr ick_clc_cset_ptr #define clcsem ick_clcsem #define clcsemantics ick_clcsemantics #define clockface ick_clockface #define coreonerr ick_coreonerr #define cset_recent ick_cset_recent #define csetow ick_csetow #define datadir ick_datadir #define debfopen ick_debfopen #define fin ick_fin #define fin16 ick_fin16 #define fin32 ick_fin32 #define findandfopen ick_findandfopen #define findandfreopen ick_findandfreopen #define findandtestopen ick_findandtestopen #define first ick_first #define globalargv0 ick_globalargv0 #define iselect ick_iselect #define lineno ick_lineno #define lose ick_lose #define lwarn ick_lwarn #define mingle ick_mingle #define multicome0 ick_multicome0 #define mystery ick_mystery #define mysteryc ick_mysteryc #define next ick_next #define nextindex ick_nextindex #define numerals ick_numerals #define or16 ick_or16 #define or32 ick_or32 #define parseargs ick_parseargs #define pin ick_pin #define popnext ick_popnext #define pout ick_pout #define printflow ick_printflow #define printfopens ick_printfopens #define pushnext ick_pushnext #define resize ick_resize #define resume ick_resume #define retrieve ick_retrieve #define rev_and16 ick_rev_and16 #define rev_and32 ick_rev_and32 #define rev_fin16 ick_rev_fin16 #define rev_fin32 ick_rev_fin32 #define rev_or16 ick_rev_or16 #define rev_or32 ick_rev_or32 #define rev_whirl16 ick_rev_whirl16 #define rev_whirl32 ick_rev_whirl32 #define rev_xor16 ick_rev_xor16 #define rev_xor32 ick_rev_xor32 #define roll ick_roll #define rotleft16 ick_rotleft16 #define rotleft32 ick_rotleft32 #define setbitcount ick_setbitcount #define smudgeleft ick_smudgeleft #define smudgeright ick_smudgeright #define stash ick_stash #define stashinit ick_stashinit #define traditional ick_traditional #define whirl ick_whirl #define whirl16 ick_whirl16 #define whirl32 ick_whirl32 #define wimp_mode ick_wimp_mode #define xor ick_xor #define xor16 ick_xor16 #define xor32 ick_xor32 #define xselx ick_xselx intercal-0.29/src/pick1.h0000644000175000017500000000631211435477314015103 0ustar brooniebroonie/* * pick1.h - Compiler-dependent defines for PIC compilers * * This file allows porting of PIC-INTERCAL output files to different * compilers. Most compilers will require this file to be modified; * as written at the moment, it's ANSI C that invokes undefined * behaviour (in a way that might plausibly produce correct * results). * LICENSE TERMS Copyright (C) 2006 Alex Smith 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. */ /* Place any headers, config fuse selection statements, and device statements your compiler needs here. */ #include /* Define these constants to unsigned data types of the correct bit width. (If your compiler doesn't use 1 bit variables, you could substitute an 8 bit variable, but that would take up extra RAM, which may or may not drive the program over the PIC's RAM limit.) */ #define ICK_INT32 uint32_t #define ICK_INT16 uint16_t #define ICK_INT8 uint8_t #define ICK_INT1 uint1_t /* Define this to an error-handling procedure. You should ignore the arguments, as they won't make too much sense in this context. This should block the program; the SLEEP command is one possibility, somehow getting the PIC to disconnect its own power supply and signal an error is another. */ #define ick_lose(a,b,c) for(;;) /* PORTA, PORTB, TRISA, and TRISB must be variables which, when read or modified, read or modify the corresponding location in the PIC's RAM; these are often at locations 0x05, 0x06, 0x85, and 0x86 respectively. Place the code to do this here, if it isn't added by the header files above. See the section below if your compiler doesn't recognize the volatile keyword, but this code is otherwise correct. */ #define PORTA *(volatile ICK_INT8*)0x05 #define PORTB *(volatile ICK_INT8*)0x06 #define TRISA *(volatile ICK_INT8*)0x85 #define TRISB *(volatile ICK_INT8*)0x86 /* This is a hack for compilers that don't interpret volatile correctly. The uncommented code assumes your compiler knows how to work it correctly; use the replacement below if it doesn't. */ #define seq(a) a /* You may need to use the commented-out code instead if your compiler is confused about volatile. ICK_INT8 seq(ICK_INT8 n) { return n; } */ void pickinit() { /* Place any initialization code that is needed here. */ } /* If your implementation doesn't use function pointers, delete this and don't write any code that uses operator-overloading. */ typedef struct ick_overop_t { ICK_INT32 (*get)(ICK_INT32); void (*set)(ICK_INT32); } ick_overop; #define ick_type16 ICK_INT16 #define ick_type32 ICK_INT32 intercal-0.29/src/perpet.c0000644000175000017500000021117611450110417015355 0ustar brooniebroonie/**************************************************************************** NAME perpet.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 "config.h" /* AIS: Generated by autoconf */ #include #include #ifdef HAVE_UNISTD_H # include #endif #include #include #include #include #include "ick.h" #include "feh.h" #include "parser.h" #include "sizes.h" #include "ick_lose.h" #include "uncommon.h" /* AIS: split ICKDATADIR from ICKLIBDIR */ #ifndef ICKINCLUDEDIR # define ICKINCLUDEDIR "/usr/local/include" #endif #ifndef ICKSYSDIR # ifdef ICKDATADIR # define ICKSYSDIR ICKDATADIR # else # define ICKSYSDIR "/usr/local/share" # endif #endif #ifndef ICKCSKELDIR # ifdef ICKDATADIR # define ICKCSKELDIR ICKDATADIR # else # define ICKCSKELDIR "/usr/local/share" # endif #endif #ifndef ICKLIBDIR # define ICKLIBDIR "/usr/local/lib" #endif #ifndef ICKBINDIR # define ICKBINDIR "/usr/local/bin" #endif #ifndef CC # define CC "gcc" #endif #define ARGSTRING "abcdefghlmoptuvwxyCEFHOPUYX@" /* unused st variable quiets a GCC4 warning */ #define ICK_SYSTEM(x) do{int st;if(showsystem)fprintf(stderr,"%s\n",x); \ st=system(x);}while(0) #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 ick_traditional; /* insist on strict INTERCAL-72 conformance */ bool nocompilerbug; /* disable error IE774 */ bool yukdebug; /* AIS: Use the yuk debugger. */ bool yukprofile; /* AIS: Use the yuk profiler. */ bool useprintflow; /* AIS: Add +printflow support. */ extern bool ick_coreonerr; /* AIS: Dump core on IE778. (defined in ick_lose.c) */ bool multithread; /* AIS: Allow multithreading and backtracking. */ bool variableconstants; /* AIS: Allow anything on the left of an assignment. */ bool createsused; /* AIS: Allow the use of CREATE. */ bool useickec; /* AIS: Link together INTERCAL and C. */ static bool nosyslib; /* AIS: Don't link syslib under any circumstances. */ static bool showsystem; /* AIS: Show the command lines in system() calls */ bool cdebug; /* AIS: Pass -g to our C compiler, and leave C code. */ int optdebug; /* AIS: Debug the optimizer. Value is 0, 1, 2, or 3. */ bool flowoptimize; /* AIS: Do flow optimizations (in INTERCAL!). */ bool coopt; /* AIS: The constant-output optimization. This should mean that INTERCAL will beat any other language at many benchmark programs (!) */ extern bool ick_printfopens; /* AIS: Print messages whenever attempting to open a file: from uncommon.c */ extern bool ick_checkforbugs;/* AIS: Try to find possible bugs in the source code */ bool pickcompile; /* AIS: Compile for PIC? */ /*@-exportlocal@*/ /* AIS: relevant to the lexer */ bool clclex; /* AIS: 1 means use CLC-INTERCAL meanings for @, ? */ /*@=exportlocal@*/ bool ick_clcsemantics; /* AIS: CLC semantics for I/O, abstaining GIVE UP, &c*/ static bool outtostdout; /* AIS: Output on stdout rather than the output file */ /* AIS: Autodetected compilation options */ int compucomecount; /* Computed COME FROM count */ bool compucomesused; /* Are computed COME FROMs used? */ bool gerucomesused; /* Is COME FROM gerund used? */ bool nextfromsused; /* Is NEXT FROM used? */ bool opoverused; /* Is operand overloading used? */ /*@null@*/ node* firstslat=0; /* The first slat expression in the program */ /*@null@*/ node* prevslat=0; /* The last slat expression used so far */ static bool dooptimize; /* do optimizations? (controlled by -O) */ static bool ick_clockface; /* set up output to do IIII for IV */ #define SKELETON "ick-wrap.c" #define PSKELETON "pickwrap.c" #define SYSLIB "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 ick_Base; int ick_Small_digits; int ick_Large_digits; unsigned int ick_Max_small; unsigned int ick_Max_large; int ick_lineno; /* after yyparse, this is the total number of statements */ /* currently supported numeric bases, not exported */ static const int maxbase = 7; static const int smallsizes[8] = {0, 0, 16, 10, 8, 6, 6, 5}; static const unsigned int maxsmalls[8] = {0, 0, 65535, 59048, 65535, 15624, 46655, 16806}; /*@observer@*/ static const char *compiler; atom *oblist = NULL, *obdex; int obcount = 0; int nonespots, ntwospots, ntails, nhybrids; int nmeshes; /* AIS */ tuple *tuples = NULL; int tuplecount = 0; tuple *optuple = NULL; /* AIS: Tuple being optimized */ /* * mappings from magic line ranges to system library components are * declared here. */ struct linerange_t { int start, end; char *libname; }; /* Note! "syslib" must be last in this list, as other parts of perpet.c care about whether syslib in particular was included. */ struct linerange_t lineranges[] = { {5000, 5699, "floatlib"}, /* the floating-point support */ {1000, 1999, "syslib"}, /* the system library */ {0, 0, NULL}, }; extern const assoc varstores[]; /* AIS: Need to know this for PIC compilation */ #ifndef HAVE_UNISTD_H /* AIS: We don't have unistd.h, so we can't use getopt. Write our own version that's less general but good enough. */ int optind=1; int optopt; int getopt(int argc, char * const *argv, const char *options) { if(optind>argc) return EOF; /* Out of command line */ if(!argv[optind]) return EOF; /* Out of command line */ while(!strcmp(argv[optind],"-")) { optind++; /* Go to ick_next argument */ if(!argv[optind]) return EOF; } if(*(argv[optind])!='-') return EOF; /* this arg is not an option */ optopt=argv[optind][1]; memmove(argv[optind]+1,argv[optind]+2,strlen(argv[optind]+1)); if(optopt=='-') {optind++; return EOF;} /* -- means end of options */ if(strchr(options, optopt)) return optopt; /* valid option */ return '?'; /* invalid option */ } #endif static int myfgetc(FILE* in) { char c; size_t dummy; dummy = fread(&c,1,1,in); if(feof(in)) return EOF; return (int)c; } static RETSIGTYPE abend(int signim) { /*@-noeffect@*/ (void) signim; /*@=noeffect@*/ ick_lose(IE778, iyylineno, (const char *)NULL); } static void print_usage(const char *prog, const 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 yacc debugging information (implies -c)\n"); fprintf(stderr,"\t-e\t:link together INTERCAL and C files as one program\n"); fprintf(stderr,"\t\t (without this option, all INTERCAL files produce\n"); fprintf(stderr,"\t\t separate output files; with it, the first file given\n"); fprintf(stderr,"\t\t must be the only INTERCAL file) (prevents -mypPf)\n"); fprintf(stderr,"\t-E\t:never include system libraries (prevents -P)\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:optimize expresssions in generated code\n"); /* AIS: Changed the help message for the previous line (because the function of -O has changed). I wrote the next group of options. */ fprintf(stderr,"\t-f\t:optimize control flow in generated code " "(prevents -yp)\n"); #ifdef HAVE_PROG_SH # ifdef HAVE_SYS_INTERPRETER fprintf(stderr,"\t-F\t:optimize everything in generated code for\n" "\t\t speed, regardless of how slow the compiler becomes or how\n" "\t\t large the object file becomes. Implies -fO, " "prevents -cdeghpyH\n"); # else fprintf(stderr,"\t-F\t:unsupported on computers without #! support\n"); # endif #else fprintf(stderr,"\t-F\t:unsupported on computers without sh or bash\n"); #endif fprintf(stderr,"\t-h\t:print optimizer debugging information " "(implies -cO)\n"); fprintf(stderr,"\t-H\t:print verbose optimizer debugging information " "(implies -cO)\n"); fprintf(stderr,"\t-hH\t:print optimizer debugging information in a\n" "\t\t different form (implies -cO)\n"); #ifdef HAVE_UNISTD_H fprintf(stderr,"\t-y\t:run the yuk debugger on the code (prevents -fme)\n"); fprintf(stderr,"\t-p\t:run the yuk profiler on the code (prevents -fme)\n"); #else fprintf(stderr,"\t-y\t:unsupported on computers without \n"); fprintf(stderr,"\t-p\t:unsupported on computers without \n"); #endif fprintf(stderr,"\t-w\t:add support for the +printflow option\n"); fprintf(stderr,"\t-m\t:allow multithreading and backtracking\n" "\t\t (prevents -ype, implies -w)\n"); fprintf(stderr,"\t-a\t:allow the use of CREATE (prevents -P)\n"); fprintf(stderr,"\t-v\t:allow anything on the left of an assignment. This " "is required\n\t\t if you want operand overloading to change " "meshes.\n\t\t (prevents -fFOP)\n"); fprintf(stderr,"\t-P\t:compile PIC-INTERCAL rather than INTERCAL\n"); fprintf(stderr,"\t\t (prevents -amFvxeE, implies -cfO)\n"); fprintf(stderr,"\t-o\t:output to stdout rather than .c (implies -c)\n"); fprintf(stderr,"\t-X\t:interpret ambiguous syntax as Princeton not\n" "\t\t Atari (i.e. CLC-INTERCAL not C-INTERCAL)\n"); fprintf(stderr,"\t-x\t:use CLC-INTERCAL rules for I/O and abstaining\n" "\t\t from a GIVE UP by label (prevents -P)\n"); fprintf(stderr,"\t-u\t:print a message whenever the compiler tries to " "open a file\n"); fprintf(stderr,"\t-U\t:dump core on IE778 after printing an error\n"); fprintf(stderr,"\t-Y\t:display the command line used whenever an external\n" "\t\t program is invoked\n"); fprintf(stderr,"\t-g\t:compile to both debuggable executable and C\n"); fprintf(stderr,"\t-l\t:attempt to report likely bugs " "and nonportabilities (implies -O)\n"); /* AIS: End of options I added. */ fprintf(stderr,"\t\tINTERCAL source file (use extension .i\n"); fprintf(stderr,"\t\tfor base 2 or .3i, etc., for base 3, etc.).\n"); } #if __DJGPP__ /* AIS: Determine whether an environment variable exists (this is used to find a temp directory) */ static int isenv(char* e) { char* x=getenv(e); return x != NULL && *x != '\0'; } #endif extern int optind; /* set by getopt */ /** * This parses command line options. * @param argc What do you think? * @param argv Likewise. * @note May (directly) call ick_lose() with IE111 and IE256. */ static void parse_options(int argc, char *argv[]) { int c; /* getopt is POSIX, and I provide my own version if the POSIX version isn't found, so the unrecog warning is a false positive. */ /*@-unrecog@*/ while ((c = getopt(argc, argv, ARGSTRING)) != EOF) /*@=unrecog@*/ { switch (c) { case 'b': nocompilerbug = true; break; case 'c': compile_only = true; /* AIS */ coopt = false; break; case 'o': /* AIS */ compile_only = true; outtostdout = true; coopt = false; break; case 'd': yydebug = 1; compile_only = true; /* AIS */ coopt = false; break; case 'e': /* AIS */ useickec = true; multithread = pickcompile = coopt = yukdebug = yukprofile = false; break; case 'E': /* AIS */ nosyslib = true; pickcompile = false; break; case 'C': ick_clockface = true; break; case 't': ick_traditional = true; if(multithread) ick_lose(IE111, 1, (const char*) NULL); /* AIS */ if(pickcompile) ick_lose(IE111, 1, (const char*) NULL); /* AIS */ break; case 'O': dooptimize = true; variableconstants = false; /* AIS */ break; case 'f': /* By AIS */ flowoptimize = true; yukdebug = yukprofile = false; variableconstants = false; break; case 'F': /* By AIS */ coopt = flowoptimize = dooptimize = true; variableconstants = useickec = false; yukdebug = yukprofile = outtostdout = compile_only = cdebug = false; yydebug = 0; if(pickcompile) ick_lose(IE256, 1, (const char*) NULL); break; case 'h': /* By AIS */ optdebug|=1; compile_only=dooptimize=true; coopt=false; break; case 'H': /* By AIS */ optdebug|=2; compile_only=dooptimize=true; coopt=false; break; case 'y': /* By AIS */ #ifdef HAVE_UNISTD_H yukdebug=true; multithread=flowoptimize=coopt=useickec=false; #endif break; case 'p': /* By AIS */ #ifdef HAVE_UNISTD_H yukprofile=true; multithread=flowoptimize=coopt=useickec=false; #endif break; case 'w': /* By AIS */ useprintflow = true; break; case 'm': /* By AIS */ multithread=true; yukprofile=false; yukdebug=false; useickec=false; if(ick_traditional) ick_lose(IE111, 1, (const char*) NULL); break; case 'a': /* By AIS */ createsused=true; pickcompile=false; break; case 'v': /* By AIS */ variableconstants=true; dooptimize=false; flowoptimize=false; coopt=false; pickcompile=false; break; case 'l': /* By AIS */ ick_checkforbugs=true; dooptimize=true; break; case 'U': /* By AIS */ ick_coreonerr=true; break; case 'u': /* By AIS */ ick_printfopens=true; break; case 'Y': /* By AIS */ showsystem=true; break; case 'P': /* By AIS */ pickcompile=true; multithread=coopt=variableconstants=createsused=false; ick_clcsemantics=useickec=nosyslib=false; compile_only=true; dooptimize=flowoptimize=true; /* needed for PICs */ break; case 'X': /* By AIS */ clclex=true; break; case 'x': /* By AIS */ ick_clcsemantics=true; pickcompile=false; break; case 'g': /* By AIS */ cdebug=true; coopt=false; break; case '?': default: case '@': print_usage(argv[0], ARGSTRING); exit(EXIT_FAILURE); /*@-unreachable@*/ break; /*@=unreachable@*/ } } } /** * This code handles archives (for -e). * @param libbuf Pointer to a buffer to which extra files to link in prelink() * will be added. Need to be initialized up to the first zero byte. * @param libbuf_size Size of the buffer libbuf. * @param library The cmd line argument used for the library (but without the * extension). */ static void handle_archive(char *libbuf, size_t libbuf_size, /*@observer@*/ const char* library) { /* AIS: request for a library. Given a filename of the form libwhatever.a, it adds -lwhatever to libbuf (that's with a preceding space). If the filename doesn't start with lib, it instead adds a space and the filename to libbuf. */ if(library[0]=='l'&&library[1]=='i'&& library[2]=='b') (void) ick_snprintf_or_die(libbuf+strlen(libbuf),libbuf_size - strlen(libbuf), " -l%s",library+3); else (void) ick_snprintf_or_die(libbuf+strlen(libbuf),libbuf_size - strlen(libbuf), " %s.a",library); } /** * This handles Befunge 98 (for -e). * @param libbuf Pointer to a buffer to which extra files to link in prelink() * will be added. Need to be initialized up to the first zero byte. * @param libbuf_size Size of the buffer libbuf. * @param libdir The ick library directory. * @param argv0 Should be argv[0], which wasn't modified. * @param filename The file name of the Befunge file (but without the extension). * @note May (directly) call ick_lose() with IE888 and IE899. */ static void handle_befunge98(char *libbuf, size_t libbuf_size, /*@observer@*/ const char* libdir, /*@observer@*/ const char* argv0, /*@observer@*/ const char* filename) { /* AIS: Compile the .b98 file into a .cio so that it can be used later, and include the necessary libraries to use it, or error if the libraries aren't installed yet. I use a somewhat dubious trick here: the .b98 file's .cio, and the necessary libraries, are added in the libraries section of the command line, whereas the space on the command line where the .b98 file was is used for the expansion library ecto_b98. This is because ecto_b98 requires preprocessing/prelinking/interprocessing or whatever you want to call it, whereas unlike for other .cios, the .cio produced from the Befunge file doesn't. */ #define MARKERMAX 128 FILE* of; int x,y,jlb; char outputfilename[BUFSIZ]; int markerposns[MARKERMAX][2]; int markercount=0; /* Error if libick_ecto_b98.a is missing. It might be, and not just due to installation problems. */ if(!ick_findandtestopen("libick_ecto_b98.a",libdir,"rb",argv0)) ick_lose(IE899,-1,(const char *)NULL); /* Compile the .b98 file into a .cio. It's open on stdin right now, so we just need to handle the output side of things. */ (void) ick_snprintf_or_die(outputfilename, sizeof outputfilename, "%s.cio", filename); if(!((of = ick_debfopen(outputfilename,"w")))) ick_lose(IE888,-1,(const char *)NULL); fprintf(of,"const unsigned char* ick_iffi_befungeString=\n\""); x=0; y=0; jlb=0; for(;;) { int c=getchar(); if(c==EOF) break; if(c==0xB7) { /* Middot (0xB7) has special handling. */ c='M'; markerposns[markercount][0]=x; markerposns[markercount++][1]=y; } if(c=='\r') {jlb = 1; x=0; y++; c='\n';} else if(c=='\n' && jlb) {jlb = 0; continue;} else if(c=='\n') {x=0; y++; jlb = 0;} else x++; fprintf(of,"\\x%x",(unsigned int)c); if(!x) fprintf(of,"\"\n\""); } fprintf(of,"\";\n\nint ick_iffi_markercount=%d;\n" "long long ick_iffi_markerposns[][2]={\n",markercount); if(!markercount) fprintf(of,"{0,0}\n"); while(markercount--) fprintf(of,"{%d,%d},\n", markerposns[markercount][0], markerposns[markercount][1]); fprintf(of,"};\n"); (void) fclose(of); /* Put the libraries and .cio file in the command line. */ (void) ick_snprintf_or_die(libbuf+strlen(libbuf),libbuf_size - strlen(libbuf), " %s.cio -lick_ecto_b98 -lm -lncurses", filename); } /** * This computes what type the INTERCAL source file is. * It will change various globals. * @param chp A pointer to the first letter of the extension of the file. Note * that it won't be changed, but can't be const char* due to being * passed as the second parameter to strtol() as well. * @note May (directly) call ick_lose() with IE111, IE256 and IE998. */ static void find_intercal_base(char* chp) { /* 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. */ ick_Base = DEFAULT_BASE; ick_Small_digits = DEFAULT_SMALL_DIGITS; ick_Large_digits = DEFAULT_LARGE_DIGITS; ick_Max_small = (unsigned)DEFAULT_MAX_SMALL; ick_Max_large = (unsigned)DEFAULT_MAX_LARGE; /* determine the file type from the extension */ while (strcmp(chp,"i")) { ick_Base = (int)strtol(chp,&chp,10); if (ick_Base < 2 || ick_Base > maxbase) ick_lose(IE998, 1, (const char *)NULL); else if (ick_traditional && ick_Base != 2) ick_lose(IE111, 1, (const char *)NULL); else if (pickcompile && ick_Base != 2) ick_lose(IE256, 1, (const char *)NULL); /* AIS */ ick_Small_digits = smallsizes[ick_Base]; ick_Large_digits = 2 * ick_Small_digits; ick_Max_small = maxsmalls[ick_Base]; if (ick_Max_small == 0xffff) ick_Max_large = (unsigned)0xffffffffLU; else ick_Max_large = (ick_Max_small + 1) * (ick_Max_small + 1) - 1; } } /** * This checks if we automagically need to include syslib * @param buffer Output buffer that may be modified to contain the path of * syslib.i or syslib.Ni (where N is 3-7). * @param size Size of buffer. * @param needsyslib Pointer to the bool needsyslib declared in main(). * @param argv0 Should be argv[0], which wasn't modified. * @param ick_sysdir The ick data directory. * @note May (directly) call ick_lose() with IE127. */ static void check_syslib(/*@partial@*/ char *buffer, size_t size, /*@out@*/ bool *needsyslib, /*@observer@*/ const char *argv0, /*@observer@*/ const char *ick_sysdir) { tuple *tp; struct linerange_t *lp; if (nosyslib || pickcompile) { *needsyslib = false; return; } /* * magical inclusion of system libraries is done here */ for (lp = lineranges; lp->start; lp++) { *needsyslib = false; for (tp = tuples; tp->type; tp++) { /* * If some label in the specified range is defined, * then assume the library we seek is already there, so we * can stop searching. */ if (tp->label >= lp->start && tp->label <= lp->end) { *needsyslib = false; goto breakout; } /* * If some label in the specified range is being * called, we might need the library. */ if (tp->type == NEXT && tp->u.target >= lp->start && tp->u.target <= lp->end) *needsyslib = true; } if (*needsyslib) { if (ick_Base == 2) (void) ick_snprintf_or_die(buffer, size, "%s.i", lp->libname); else (void) ick_snprintf_or_die(buffer, size, "%s%d.%di", lp->libname, ick_Base, ick_Base); if (ick_findandfreopen(buffer, ick_sysdir, "r", argv0, stdin) == NULL) ick_lose(IE127, 1, (const char*) NULL); #ifdef USE_YYRESTART yyrestart(stdin); #endif /* USE_YYRESTART */ (void) yyparse(); textlinecount=iyylineno; } breakout: ; } } /** * This code propagates type information up the expression tree. * It also does some unrelated stuff such as checking for WRITE IN and disabling * coopt if that is found. */ static void propagate_typeinfo(void) { tuple *tp; /* * 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 == WRITE_IN || tp->type == READ_OUT || tp->type == FROM || tp->type == MANYFROM || tp->type == FORGET || tp->type == RESUME || tp->type == COMPUCOME || tp->type == UNKNOWN) typecast(tp->type == MANYFROM ? tp->u.node->lval : tp->u.node); if (tp->type == WRITE_IN) coopt = false; /* AIS: may as well do this here */ } } /** * This runs the optimiser. */ static void run_optimiser(void) { tuple *tp; /* perform optimizations */ if (dooptimize) for (tp = tuples; tp->type; tp++) { /* AIS: Allow breaching of the only specification on tuples at this point; I've checked that tuples isn't reallocated during the block, so this is fine. */ /*@-onlytrans@*/ optuple = tp; /*@=onlytrans@*/ if (tp->type == GETS || tp->type == RESIZE || tp->type == FORGET || tp->type == RESUME || tp->type == FROM || tp->type == COMPUCOME) optimize(tp->u.node); if (tp->type == MANYFROM) optimize(tp->u.node->lval); } /* AIS: Added FROM and MANYFROM support. */ /* AIS: perform flow optimizations */ if (flowoptimize) optimizef(); } /** * Generate random line number for E774. * @returns A random line number, or -1 for no random bug generated. */ static int randomise_bugline(void) { /* decide if and where to place the compiler bug */ #ifdef USG if (!nocompilerbug && lrand48() % 10 == 0) return (int)(lrand48() % ick_lineno); #else if (!nocompilerbug && rand() % 10 == 0) return rand() % ick_lineno; #endif else return -1; } /** * This opens the outfile. * @param filename The filename to open. * @returns A pointer to a FILE for the filename. If the global outtostdout is * set then it will return stdout. * @note May (directly) call ick_lose() with IE888. */ static /*@dependent@*/ FILE* open_outfile(/*@observer@*/ const char * filename) { FILE *ofp; /* AIS: ofp holds fopened storage if !outtostdout, and local-copy storage if outtostdout, and this is not a bug, although it confuses Splint. */ /*@-branchstate@*/ if(outtostdout) ofp=stdout; /* AIS */ else if((ofp = ick_debfopen(filename, "w")) == (FILE *)NULL) ick_lose(IE888, 1, (const char *)NULL); /*@=branchstate@*/ return ofp; } /** * This generates the CC command line. * @param buffer Output buffer. * @param size Size of the output buffer. * @param sourcefile The name of the C file. * @param includedir The ick include directory. * @param path The path of the ick binary (execuding filename). * @param libdir The ick library directory. * @param outputfile The name of the output file. */ static void gen_cc_command(char* buffer, size_t size, /*@observer@*/ const char* sourcefile, /*@observer@*/ const char* includedir, /*@observer@*/ const char* path, /*@observer@*/ const char* libdir, /*@observer@*/ const char* outputfile) { (void) ick_snprintf_or_die(buffer, size, "%s %s%s-I%s -I%s -I%s/../include -L%s -L%s -L%s/../lib -O%c -o %s" EXEEXT " -lick%s%s", #ifdef __DJGPP__ "", #else compiler, #endif #ifdef HAVE_CLOCK_GETTIME /* implies -lrt is available */ sourcefile, yukdebug||yukprofile?" -lyuk -lrt ":" ", #else sourcefile, yukdebug||yukprofile?" -lyuk ":" ", #endif includedir, path, path, libdir, path, path, cdebug?'0':coopt?'3':'2', /* AIS: If coopting, optimize as much as possible JH: [d]on't optimise when compiling with debugger support */ outputfile, multithread?"mt":"", cdebug?" -g":""); /* AIS: Possibly link in the debugger yuk and/or libickmt.a here. */ /* AIS: Added -g support. */ /* AIS: Added argv[0] (now path) to the -I, -L settings. */ } /** * This generates the actual C code. * @param ifp This should be opened to either ick-wrap.c or pickwrap.c. * @param ofp The out file. * @param source_name_stem Source name stem * @param needsyslib Pointer to the needsyslib bool in main(). * @param bugline What line number to add a random bug to. * @param compilercommand The compiler command line. * @note May (directly) call ick_lose() with IE256. */ static void generate_code(FILE *ifp, FILE *ofp, /*@observer@*/ const char* source_name_stem, bool *needsyslib, int bugline, /*@observer@*/ const char* compilercommand) { int maxabstain; int c, i; tuple *tp; atom *op; while ((c = myfgetc(ifp)) != EOF) if (c != (int)'$') (void) fputc(c, ofp); else switch(myfgetc(ifp)) { case 'A': /* source name stem */ (void) fputs(source_name_stem, ofp); break; case 'B': /* # of statements */ (void) fprintf(ofp, "%d", ick_lineno); break; case 'C': /* initial abstentions */ /* AIS: Modified to check for coopt, pickcompile */ maxabstain = 0; for (tp = tuples; tp->type; tp++) if (((tp->exechance <= 0 || tp->exechance >= 101) && tp - tuples + 1 > maxabstain) || coopt || pickcompile) maxabstain = tp - tuples + 1; if (maxabstain) { if(!pickcompile) (void) fprintf(ofp, " = {"); for (tp = tuples; tp < tuples + maxabstain; tp++) { if(tp->exechance != 100 && tp->exechance != -100) { /* AIS: The double-oh-seven operator prevents coopt working. However, syslib contains a double-oh-seven. feh.c has checked that that isn't referenced; if it isn't, we can allow one double-oh-seven if syslib was automagically inclulded. */ if(*needsyslib) *needsyslib = false; else coopt = false; } if(!pickcompile) { if (tp->exechance > 0) { (void) fprintf(ofp, "0, "); tp->initabstain=0; /* AIS: -f might not be given, so we can't rely on dekludge.c doing this */ } else { (void) fprintf(ofp, "1, "); tp->exechance = -tp->exechance; tp->initabstain=true; /* AIS: As above */ /* AIS: If the line was ick_abstained, we need to swap ONCEs and AGAINs on it round, to suit the code degenerator. */ if(tp->onceagainflag == onceagain_ONCE) tp->onceagainflag = onceagain_AGAIN; else if(tp->onceagainflag == onceagain_AGAIN) tp->onceagainflag = onceagain_ONCE; } if(tp->exechance >= 101) { /* AIS: This line has a MAYBE */ tp->maybe = true; tp->exechance /= 100; } else tp->maybe = false; } else /* AIS: hardcoded abstain bits for PICs */ { if(!tp->abstainable) continue; if(tp->exechance > 0) (void) fprintf(ofp, "ICK_INT1 ICKABSTAINED(%d)=0;\n",(int)(tp-tuples)); else (void) fprintf(ofp, "ICK_INT1 ICKABSTAINED(%d)=1;\n",(int)(tp-tuples)); } } if(!pickcompile) (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 || tp->type == MANYFROM) maxabstain++; if (maxabstain || /* AIS */ gerucomesused) { int j=0; /* AIS */ /* AIS: Changed to use enablersm1 */ i = 0; for (;i < (int)(sizeof(enablersm1)/sizeof(char *));i++) (void) fprintf(ofp, "#define %s\t%d\n", enablersm1[i], i); (void) fprintf(ofp, "int linetype[] = {\n"); for (tp = tuples; tp->type; tp++) if(tp->ppnewtype) /* AIS */ (void) fprintf(ofp," %s,\n", enablers[tp->ppnewtype - GETS]); else if(tp->preproc) /* AIS */ (void) fprintf(ofp," PREPROC,\n"); else if (tp->type >= GETS && tp->type <= FROM) /* AIS: FROM added */ (void) fprintf(ofp, " %s,\n", enablers[tp->type - GETS]); else /* AIS: I didn't change this code, but relied on it when implementing just-in-case compilation; SPLATTERED and UNKNOWN (the two types of syntax error, unsalvageable and salvageable respectively) both become UNKNOWN in the linetypes array. */ (void) fprintf(ofp, " UNKNOWN,\n"); (void) fprintf(ofp, "};\n"); /* AIS: Implement the reverse of this array too (i.e. from line types to lines); this significantly speeds up up reinstate/abstain on gerunds. Joris Huizer originally suggested the optimisation in question; this implements the same algorithm in a more maintainable way. (I didn't want to have to keep five copies of the command list in sync; two is bad enough!) */ (void) fprintf(ofp, "int revlinetype[] = {\n"); for(i=0;i < (int)(sizeof(enablersm1)/sizeof(char *));i++) { (void) fprintf(ofp,"/* %s */",enablersm1[i]); for (tp = tuples; tp->type; tp++) { if((tp->ppnewtype && tp->ppnewtype-GETS == i-1) || (!tp->ppnewtype && tp->preproc && i-1 == PREPROC-GETS) || (!tp->ppnewtype && !tp->preproc && tp->type >= GETS && tp->type <= FROM && tp->type-GETS == i-1) || (!i && !tp->ppnewtype && !tp->preproc && (tp->type < GETS || tp->type > FROM))) (void) fprintf(ofp, " %ld,",(long)(tp-tuples)); } (void) fprintf(ofp,"\n"); } (void) fprintf(ofp, "};\n"); (void) fprintf(ofp, "int revlineindex[] = {\n"); for(i=0;i < (int)(sizeof(enablersm1)/sizeof(char *));i++) { (void) fprintf(ofp,"/* %s */",enablersm1[i]); (void) fprintf(ofp," %d,\n",j); for (tp = tuples; tp->type; tp++) { if((tp->ppnewtype && tp->ppnewtype-GETS == i-1) || (!tp->ppnewtype && tp->preproc && i-1 == PREPROC-GETS) || (!tp->ppnewtype && !tp->preproc && tp->type >= GETS && tp->type <= FROM && tp->type-GETS == i-1) || (!i && !tp->ppnewtype && !tp->preproc && (tp->type < GETS || tp->type > FROM))) j++; } } (void) fprintf(ofp, "/* end */ %d\n};\n",j); } break; case 'E': /* extern to intern map */ if(!pickcompile) { (void) fprintf(ofp,"int ick_Base = %d;\n",ick_Base); (void) fprintf(ofp,"int ick_Small_digits = %d;\n", ick_Small_digits); (void) fprintf(ofp,"int ick_Large_digits = %d;\n", ick_Large_digits); (void) fprintf(ofp,"unsigned int ick_Max_small = 0x%x;\n", ick_Max_small); (void) fprintf(ofp,"unsigned int ick_Max_large = 0x%x;\n", ick_Max_large); if (yukprofile || yukdebug || multithread || useickec) { /* AIS: yuk.c, multithreading require all these to exist */ if(!nonespots) nonespots = 1; if(!ntwospots) ntwospots = 1; if(!ntails) ntails = 1; if(!nhybrids) nhybrids = 1; } else if(opoverused) { /* AIS: The operand-overloading code requires onespot and twospot variables to exist. */ if(!nonespots) nonespots = 1; if(!ntwospots) ntwospots = 1; } /* AIS:I de-staticed all these so they could be accessed by yuk and cesspool, and added all the mentions of yuk and multithread. Then I changed it so the variables would be allocated dynamically, to speed up multithreading. (It's an O(1) change to the speed of ordinary programs, so I thought I could get away with it. The order is wrt the number of lines in the program. The change is O(n) wrt the number of variables, but again I hope that doesn't matter, and I won't get the entire INTERCAL community angry with me for daring to implement an extension that slows down existing programs.) */ if (variableconstants) /* AIS */ { int temp=0; (void) fprintf(ofp, "ick_type32 meshes[%d] = {",nmeshes); while(temptype!=MESH) /* AIS: Added this check */ (void) fprintf(ofp, " /* %s %lu -> %lu */\n", nameof(op->type, vartypes), op->extindex, op->intindex); } if (yukdebug || yukprofile) { /* AIS: drop intern to extern map into the program */ (void) fprintf(ofp, "\nyukvar yukvars[]={\n"); assert(oblist != NULL); for (op = oblist; op < obdex; op++) if(op->type!=MESH) /* AIS: Added this check */ (void) fprintf(ofp," {%s,%lu,%lu},\n", nameof(op->type, vartypes), op->extindex, op->intindex); (void) fprintf(ofp," {YUKEND,0,0}};\n"); } else if(useickec) { /* AIS: likewise, but with different identifiers */ (void) fprintf(ofp, "\nick_ec_var ick_ec_vars[]={\n"); assert(oblist != NULL); for (op = oblist; op < obdex; op++) if(op->type!=MESH) (void) fprintf(ofp," {%s,%lu,%lu},\n", nameof(op->type, vartypes), op->extindex, op->intindex); (void) fprintf(ofp," {ICK_EC_VARS_END,0,0}};\n"); } } else { /* Compiling for PIC */ /* Arrays not supported on PICs */ if(ntails || nhybrids) ick_lose(IE256, iyylineno, (const char*) NULL); /* and neither are variable constants */ if(variableconstants) ick_lose(IE256, iyylineno, (const char*) NULL); assert(oblist != NULL); for (op = oblist; op < obdex; op++) { (void) fprintf(ofp, " /* %s %lu -> %lu */\n", nameof(op->type, vartypes), op->extindex, op->intindex); (void) fprintf(ofp, "#define %s%lu %s[%lu]\n", nameof(op->type, vartypes), op->extindex, nameof(op->type, varstores), op->intindex); if(op->ignorable) (void) fprintf(ofp, "ICK_INT1 ignore%s%lu = 0;\n", nameof(op->type, varstores), op->intindex); } (void) fprintf(ofp, "#include \"pick1.h\"\n"); if(nonespots) { (void) fprintf(ofp, "ICK_INT16 ick_onespots[%d];\n" "ICK_INT16 onespotsstash[%d];\n", nonespots, nonespots); if(opoverused) /* AIS */ { int temp=nonespots; (void) fprintf(ofp,"ick_overop* ick_oo_onespots;\n"); while(temp--) (void) fprintf(ofp, "ick_type32 og1spot%d(ick_type32 t)\n{\n (void)t;\n return ick_onespots[%d];\n}\n" "void os1spot%d(ick_type32 val,void(*f)())\n{\n (void)f;\n if(!ignoreonespots%d)" " ick_onespots[%d]=val;\n}\n",temp,temp,temp,temp,temp); } } if(ntwospots) { (void) fprintf(ofp, "ICK_INT32 ick_twospots[%d];\n" "ICK_INT32 twospotsstash[%d];\n", ntwospots, ntwospots); if(opoverused) /* AIS */ { int temp=ntwospots; (void) fprintf(ofp,"ick_overop* ick_oo_twospots;\n"); while(temp--) (void) fprintf(ofp, "ick_type32 og2spot%d(ick_type32 t)\n{\n (void)t;\n return ick_twospots[%d];\n}\n" "void os2spot%d(ick_type32 val,void(*f)())\n{\n (void)f;\n if(!ignoretwospots%d)" " ick_twospots[%d]=val;\n}\n",temp,temp,temp,temp,temp); } } (void) fprintf(ofp, "#include \"pick2.h\"\n"); } break; case 'F': /* set options from command line */ if (ick_clockface) (void) fprintf(ofp, "ick_clockface(true);\n"); if (ick_clcsemantics) /* AIS */ (void) fprintf(ofp, "ick_setclcsemantics(true);\n"); break; case 'G': /* degenerated code */ for (tp = tuples, i = 0; tp->type; tp++, i++) { emit(tp, ofp); if (i == bugline) (void) fprintf(ofp, " ick_lose(IE774, ick_lineno, " "(char *)NULL);\n"); } break; case 'H': /* COMPUCOME, and dispatching for resumes */ /* AIS: Added COMPUCOME here. This line must be fully guarded to prevent a longjmp to an uninitialised buffer (it's guarded by a ick_lose() in ick-wrap.c.) Also checks for multithread; programs that mix normal and computed COME FROM need to use the same conventions for both, so even if no computed COME FROMs are used, the normal ones need this line so that COME FROMs can be handled consistently.*/ if(compucomesused || multithread) { (void) fprintf(ofp, "CCFL: ; CCF%d: longjmp(ick_cjb,1);\n", compucomecount); } break; case 'J': /* # of source file lines */ (void) fprintf(ofp, "%d", iyylineno); break; case 'K': /* AIS: yuk information (or not) */ if(yukdebug||yukprofile) { (void) fprintf(ofp, "#include \"config.h\"\n\n"); (void) fprintf(ofp, "#include \"yuk.h\"\n\n"); (void) fprintf(ofp, "char* textlines[] = {\n"); emittextlines(ofp); /* from feh.c */ (void) fprintf(ofp, "\"\"};\n\n"); (void) fprintf(ofp, "char* yukexplain[] = {\n"); for (tp = tuples; tp->type; tp++) { if (tp->type == GETS || tp->type == FORGET || tp->type == RESUME || tp->type == FROM || tp->type == COMPUCOME || tp->type == MANYFROM) { (void) fprintf(ofp, "\""); explexpr(tp->type == MANYFROM ? tp->u.node->lval : tp->type == GETS ? tp->u.node->rval : tp->u.node, ofp); (void) fprintf(ofp, "\",\n"); } else (void) fprintf(ofp, "0,"); } (void) fprintf(ofp, "0};\n\n"); (void) fprintf(ofp, "int lineofaboff[] = {\n"); for (tp = tuples; tp->type; tp++) { fprintf(ofp,"%d,",tp->ick_lineno); } (void) fprintf(ofp, "-1};\n\n"); /*@+boolint@*/ (void) fprintf(ofp, "int yukopts = %d;\n", yukprofile+yukdebug*2); /*@=boolint@*/ (void) fprintf(ofp, "yptimer ypexectime[%d];\n", ick_lineno); (void) fprintf(ofp, "ypcounter ypexecount[%d];\n",ick_lineno); (void) fprintf(ofp, "ypcounter ypabscount[%d];\n",ick_lineno); } break; case 'L': /* AIS: increase Emacs compatibility */ (void) fprintf(ofp, "/* -*- mode:c; compile-command:\"%s%s%s\" -*- */", #ifdef __DJGPP__ compiler," ", #else "","", #endif compilercommand); break; case 'M': /* AIS: place new features defines in program */ /* This is needed even in a non-multithread program, to let the header files know it's non-multithread */ (void) fprintf(ofp, "#define MULTITHREAD %d\n", multithread?1:0); /* Likewise, to let the header files know whether it overloads operands (I don't think this is used at the moment, though) */ (void) fprintf(ofp, "#define OPOVERUSED %d\n",opoverused?1:0); /* and whether to use the ICK_EC code */ if(useickec) (void) fprintf(ofp, "#define ICK_EC 1\n"); break; case 'N': /* allocate variables */ /* AIS:I de-staticed all these so they could be accessed by yuk and cesspool, and added all the mentions of yuk and multithread. Then I changed it so the variables would be allocated dynamically, to speed up multithreading (it's an O(1) change to the speed of ordinary programs, so I thought I could get away with it). At this point, the 'E' case must already have been done. calloc sets all the integer values to 0, as before. In the case of arrays, it will not zero pointers, but the number-of- dimensions value will become 0, which can serve as a 'deallocated' flag. */ if (nonespots) { if(!pickcompile) /* AIS */ { (void) fprintf(ofp, " ick_onespots = calloc(" "%d, sizeof *ick_onespots);\n", nonespots); (void) fprintf(ofp, " ick_oneforget = calloc(" "%d, sizeof *ick_oneforget);\n", nonespots); } if(opoverused) { int temp=nonespots; (void) fprintf(ofp, " ick_oo_onespots=malloc(%d*sizeof*ick_oo_onespots);\n",temp); while(temp--) (void) fprintf(ofp, " ick_oo_onespots[%d].get=og1spot%d;\n ick_oo_onespots[%d].set=os1spot%d;\n", temp,temp,temp,temp); } } if (ntwospots) { if(!pickcompile) { (void) fprintf(ofp, " ick_twospots = calloc(" "%d, sizeof *ick_twospots);\n", ntwospots); (void) fprintf(ofp, " ick_twoforget = calloc(" "%d, sizeof *ick_twoforget);\n", ntwospots); } if(opoverused) { int temp=ntwospots; (void) fprintf(ofp, " ick_oo_twospots=malloc(%d*sizeof*ick_oo_twospots);\n",temp); while(temp--) (void) fprintf(ofp, " ick_oo_twospots[%d].get=og2spot%d;\n ick_oo_twospots[%d].set=os2spot%d;\n", temp,temp,temp,temp); } } if (ntails&&!pickcompile) { (void) fprintf(ofp, " ick_tails = calloc(" "%d, sizeof *ick_tails);\n", ntails); (void) fprintf(ofp, " ick_tailforget = calloc(" "%d, sizeof *ick_tailforget);\n", ntails); } if (nhybrids&&!pickcompile) { (void) fprintf(ofp, " ick_hybrids = calloc(" "%d, sizeof *ick_hybrids);\n", nhybrids); (void) fprintf(ofp, " ick_hyforget = calloc(" "%d, sizeof *ick_hyforget);\n", nhybrids); } break; case 'O': /* AIS; for GERUCOME and operand overloading */ if(gerucomesused || nextfromsused) fprintf(ofp,"unsigned truelineno = 0;\n"); if(opoverused) fprintf(ofp,"%s trueval;\n", pickcompile?"ICK_INT32":"ick_type32"); break; case 'P': /* AIS: for operand overloading */ if(opoverused) emitslatproto(ofp); break; case 'Q': /* AIS: for operand overloading */ if(opoverused) emitslat(ofp); break; } } /** * This runs the C compiler, and may invoke yuk. * @param cc_command The compiler command line to use. Constructed by gen_cc_command(). * @param oldstdin The previous stdin, used for yuk. * @param yukcmdstr The command line to use for running yuk. * @param sourcefile The output filename. * @param binaryname The name of the binary. */ static void run_cc_and_maybe_debugger(/*@observer@*/ const char *cc_command, int oldstdin, /*@observer@*/ const char *yukcmdstr, /*@observer@*/ const char *sourcefile, /*@observer@*/ const char *binaryname) { #ifndef __DJGPP__ /* OK, now sic the C compiler on the results */ if (!compile_only&&!yukdebug&&!yukprofile&&!useickec) { /* AIS: buf2 now assigned elsewhere so $L works */ ICK_SYSTEM(cc_command); /* AIS: no unlink if cdebug */ if(!cdebug) (void) unlink(sourcefile); } else if(!compile_only&&!useickec) { /* AIS: run, then delete all output but yuk.out */ /* Note that the output must be deleted for copyright reasons (so as not to GPL a non-GPL file automatically) */ ICK_SYSTEM(cc_command); #ifdef HAVE_UNISTD_H (void) dup2(oldstdin,0); /* restore stdin */ #endif ICK_SYSTEM(yukcmdstr); (void) unlink(sourcefile); (void) unlink(binaryname); } #else /* we are using DJGPP */ /* OK, now sic the C compiler on the results */ if (!compile_only&&!useickec) { /* AIS: buf2 now assigned elsewhere so $L works */ /* AIS: This changes somewhat for DJGPP, due to the command-line cap. It creates a temporary file with the arguments needed to give gcc. */ FILE* rsp; /* Use current dir as temp if needed */ const char* tempfn="gcc @ickgcc.rsp"; /* Four tries are used to find a temp directory. ICKTEMP is the preferred environment variable to check; if, as expected, this isn't set, try TMPDIR (which DJGPP sets to its own temp directory, at least when running under bash), TEMP and TMP (in that order). DJGPP offers /dev/env as a method of accessing environment variables in filenames.*/ if(isenv("TMP")) tempfn="gcc @/dev/env/TMP/ickgcc.rsp"; if(isenv("TEMP")) tempfn="gcc @/dev/env/TEMP/ickgcc.rsp"; if(isenv("TMPDIR")) tempfn="gcc @/dev/env/TMPDIR/ickgcc.rsp"; if(isenv("ICKTEMP")) tempfn="gcc @/dev/env/ICKTEMP/ickgcc.rsp"; rsp=ick_debfopen(tempfn+5,"w"); fprintf(rsp,"%s\n",cc_command); fclose(rsp); ICK_SYSTEM(tempfn); remove(tempfn+5); if(yukdebug || yukprofile) { char buffer[BUFSIZ]; #ifdef HAVE_UNISTD_H dup2(oldstdin,0); /* restore stdin */ #endif /* FIXME: This looks broken (the buf2 usage and such). */ ick_snprintf_or_die(buffer, sizeof(buffer), "%s" EXEEXT,binaryname); ICK_SYSTEM(yukcmdstr); remove(sourcefile); remove(buffer); } else if(!cdebug) { remove(sourcefile); } } #endif } /** * This runs coopt.sh if -F is given and the program can be "coopted". * @param cooptsh Path to coopt.sh * @param binaryname The output binary filename. */ static void run_coopt(/*@observer@*/ /*@null@*/ /*@unused@*/ const char* cooptsh, /*@observer@*/ /*@unused@*/ const char* binaryname) { /* Note: Params are marked unused because they may not be used if sh isn't supported. */ /* Assume that sh exists if #! does; sh is needed to run autoconf, so this would otherwise have to be set by hand anyway. */ #ifdef HAVE_SYS_INTERPRETER if(coopt) /* AIS */ { /* The constant-output optimizer is a form of post-processor. IMPORTANT NOTE: This MUST NOT be run if the input program takes any input or is affected in any way by the state of the system, as the degenerated program may be wrong. At the moment, the only INTERCAL command that takes input is WRITE IN. Double-oh-sevens screw this up, too. */ if(cooptsh) { char commandlinebuf[BUFSIZ]; (void) ick_snprintf_or_die(commandlinebuf, sizeof commandlinebuf, "sh %s %s", cooptsh, binaryname); ICK_SYSTEM(commandlinebuf); /* replaces the output executable if neccesary */ } } #endif } /** * This is for -e, runs prelinking. * @param argc Exactly what you think. * @param argv Also what you think. * @param oldoptind The original optind. * @param libdir The ick library directory. * @param includedir The ick include directory. * @param path The path of the ick binary (execuding filename). * @param libbuf A string with -lfoo to add to compiler command line. * @note May (directly) call ick_lose() with IE666. IE778 and IE888. */ static void prelink(int argc, char *argv[], int oldoptind, /*@observer@*/ const char* libdir, /*@observer@*/ const char *includedir, /*@observer@*/ const char* path, /*@observer@*/ const char* libbuf) { char buffer[BUFSIZ]; FILE* cioin; FILE* cioallec; char* buf2ptr; long remspace; const char* tempfn="ickectmp.c"; int needc99=0; #if __DJGPP__ /* Look for a temp directory, as above. */ if(isenv("TMP")) tempfn="/dev/env/TMP/ickectmp.c"; if(isenv("TEMP")) tempfn="/dev/env/TEMP/ickectmp.c"; if(isenv("TMPDIR")) tempfn="/dev/env/TMPDIR/ickectmp.c"; if(isenv("ICKTEMP")) tempfn="/dev/env/ICKTEMP/ickectmp.c"; #else tempfn="/tmp/ickectmp.c"; /* always a valid temporary folder on POSIX */ #endif cioallec=ick_debfopen(tempfn,"w"); if(cioallec == NULL) ick_lose(IE888, -1, (const char*) NULL); (void) fprintf(cioallec,"void ick_doresume(unsigned short,int);\n"); (void) fprintf(cioallec,"extern int ick_global_checkmode;\n"); (void) fprintf(cioallec,"void ick_allecfuncs(void)\n{\n"); /* Here, we run the C preprocessor on the files in question, then our own preprocessor, and finally link all the files together into one executable. */ for(optind=oldoptind; optind < argc; optind++) { (void) ick_snprintf_or_die(buffer, sizeof buffer, "%s --std=c%d -E -DICK_HAVE_STDINT_H=%d " "-I%s -I%s -I%s/../include " "-x c %s.c%c%c > %s.cio", compiler, argv[optind][strlen(argv[optind])+2]=='9'?99:89, ICK_HAVE_STDINT_H+1-1, includedir, path, path, argv[optind], argv[optind][strlen(argv[optind])+2]=='9'? (needc99=1),'9':' ', argv[optind][strlen(argv[optind])+2]=='9'?'9':' ', argv[optind]); if(*(argv[optind]) && /* there is some file to compile */ (argv[optind][strlen(argv[optind])+2]=='\0' /* a .c or .i file */ ||argv[optind][strlen(argv[optind])+3]!='o')) /* not a .cio file */ ICK_SYSTEM(buffer); /* run the C preprocessor */ buf2ptr = strrchr(buffer,'>'); /* get the .cio's filename */ cioin=NULL; /* Do our preprocessing, by editing the file in place using rb+. */ if(buf2ptr != NULL && buf2ptr[1] != '\0' && buf2ptr[2] != '\0') cioin=ick_debfopen(buf2ptr+2,"rb+"); if(cioin) { int inchar=fgetc(cioin); int toparencount=0; /* The ppnums are replacements for strings in the .cio file. The choice of 65538 means that we don't clash with any line numbers in the program, but do clash with the other C-INTERCAL preprocessor (that handles WHILE); that isn't a problem because external calls are inconsistent with multithreading anyway. */ static long ppnum1=65538L*2L; static long ppnum2=65538L*2L; static long ppnum3=65538L*2L; static long ppnum6=65538L*2L; long ciopos=0L; /*@+charintliteral@*/ /* literal chars are ints */ while(inchar != EOF) { if(inchar=='I') { /* Look for the ICK_EC_PP_ string that indicates preprocessing is needed. This method of doing it works as long as the ICK_EC_PP_ string is never preceded by something which looks like part of the same string, but luckily, it never is. */ if((inchar=fgetc(cioin))!='C') continue; if((inchar=fgetc(cioin))!='K') continue; if((inchar=fgetc(cioin))!='_') continue; if((inchar=fgetc(cioin))!='E') continue; if((inchar=fgetc(cioin))!='C') continue; if((inchar=fgetc(cioin))!='_') continue; if((inchar=fgetc(cioin))!='P') continue; if((inchar=fgetc(cioin))!='P') continue; if((inchar=fgetc(cioin))!='_') continue; inchar=fgetc(cioin); toparencount=0; if(inchar=='0') { fprintf(cioallec,"#undef X\n"); fprintf(cioallec,"#define X "); while(fputc(fgetc(cioin),cioallec) != ')') toparencount++; } (void) fseek(cioin,ciopos,SEEK_SET); switch(inchar) { case '0': /* a function exists */ fprintf(cioin," "); fprintf(cioallec,"\nvoid X(void); X();\n" "if(ick_global_checkmode==5) ick_doresume(1,-1);\n"); while(toparencount--) (void) fputc(' ',cioin); break; case '1': fprintf(cioin,"%-11ld",ppnum1++/2); break; case '2': fprintf(cioin,"%-11ld",ppnum2++/2); break; case '3': fprintf(cioin,"%-11ld",ppnum3++/2); break; case '4': fprintf(cioin,"%-11d",optind); break; case '6': fprintf(cioin,"%-11ld",ppnum6++/2); break; default: ick_lose(IE778, -1, (const char*) NULL); } (void) fseek(cioin,0L,SEEK_CUR); /* synch the file */ } ciopos=ftell(cioin); inchar=fgetc(cioin); } /*@=charintliteral@*/ (void) fclose(cioin); } } fprintf(cioallec,"if(ick_global_checkmode==2)\n"); fprintf(cioallec," ick_global_checkmode=4;\n"); fprintf(cioallec,"};\n"); (void) fclose(cioallec); /* NOTE: buffer changes use around here. */ /* This command line needs some explanation, and is specific to gcc and GNU ld. The -x causes gcc to interpret the .cio files as C; the -Wl,-z,muldefs is an instruction to GNU ld, telling it to link in the first main found and ignore the others. (That way, there can be a main function in each .cio, but the .cios can be linked in any order, with the right main function foremost each time.) */ (void) ick_snprintf_or_die(buffer, sizeof buffer, "%s -L%s -L%s -L%s/../lib -O2 -o %s" EXEEXT "%s " #ifndef __DJGPP__ "-Wl,-z,muldefs " #endif "-DICK_HAVE_STDINT_H=%d -x c --std=c%d %s", compiler, libdir, path, path, argv[oldoptind], cdebug?" -g":"", ICK_HAVE_STDINT_H+1==2?1:0, needc99?99:89,tempfn); remspace = (long)(sizeof buffer - strlen(buffer) - 1); for(optind=oldoptind; optind < argc; optind++) { if(!*(argv[optind])) continue; remspace -= strlen(argv[optind]) - 5; /* 5 for .cio */ if(remspace <= 0) ick_lose(IE666, -1, (const char*)NULL); strcat(buffer," "); strcat(buffer,argv[optind]); strcat(buffer,".cio"); } remspace -= strlen(libbuf); if(remspace <= 0) ick_lose(IE666, -1, (const char*)NULL); strcat(buffer,libbuf); remspace -= strlen(" -lickec"); if(remspace <= 0) ick_lose(IE666, -1, (const char*)NULL); strcat(buffer," -lickec"); ICK_SYSTEM(buffer); (void) remove(tempfn); } /*@-redef@*/ int main(int argc, char *argv[]) /*@=redef@*/ { char buf[BUFSIZ], buf2[BUFSIZ], *chp, yukcmdstr[BUFSIZ], path[BUFSIZ], libbuf[BUFSIZ]; /*@-shadow@*/ /* no it doesn't, cesspool isn't linked to perpet */ const char *includedir, *libdir, *ick_sysdir, *ick_cskeldir; /*@=shadow@*/ /* AIS: removed getenv(), added ick_sysdir */ const char *cooptsh; /* AIS */ FILE *ifp, *ofp; int /* nextcount, AIS */ bugline; bool needsyslib, firstfile; int oldoptind; #ifdef HAVE_UNISTD_H int oldstdin; /* AIS: for keeping track of where stdin was */ #endif if (!(includedir = getenv("ICKINCLUDEDIR"))) includedir = ICKINCLUDEDIR; if (!(libdir = getenv("ICKLIBDIR"))) libdir = ICKLIBDIR; if (!(ick_sysdir = getenv("ICKSYSDIR"))) ick_sysdir = ICKSYSDIR; if (!(ick_cskeldir = getenv("ICKCSKELDIR"))) ick_cskeldir = ICKCSKELDIR; /* AIS: nothing actually uses this at the moment, commenting it out for future use if (!(bindir = getenv("ICKBINDIR"))) bindir = ICKBINDIR; */ if (!(compiler = getenv("CC"))) compiler = CC; /* Parse the options. */ parse_options(argc, argv); (void) signal(SIGSEGV, abend); #ifdef SIGBUS (void) signal(SIGBUS, abend); #endif /* SIGBUS */ if (!nocompilerbug) { #ifdef USG srand48(time(NULL) + getpid()); #else srand((unsigned)time(NULL)); #endif /* UNIX */ } /* AIS: New function for enhanced file-finding */ ifp = ick_findandfopen(pickcompile?PSKELETON:SKELETON, ick_cskeldir, "r", argv[0]); if(!ifp) ick_lose(IE999, 1, (const char *)NULL); /* now substitute in tokens in the skeleton */ /* AIS: This doesn't actually seem to do anything, and buf is uninitialised at this point, so it's actually dangerous because it's undefined behaviour. buf[strlen(buf) - 2] = '\0'; */ /* AIS: Save the old stdin, if we can */ #ifdef HAVE_UNISTD_H oldstdin=dup(0); #endif oldoptind=optind; /* AIS */ *libbuf = '\0'; /* AIS */ /* Begin file loop */ for (firstfile = true; optind < argc; optind++, firstfile = false) { /* AIS: Read as binary to pick up Latin-1 and UTF-8 better */ if (/* AIS */ strrchr(argv[optind],'.') != NULL && freopen(argv[optind], "rb", stdin) == (FILE *)NULL && /* AIS */ strcmp(strchr(argv[optind],'.')+1,"a")) ick_lose(IE777, 1, (const char *)NULL); else { /* strip off the file extension */ if(!(chp = strrchr(argv[optind],'.'))) { if(useickec && firstfile == false) /* By AIS */ { /* the filename indicates a request for an expansion library, along the same lines as CLC-INTERCAL's preloads. Search for it in the usual places, then make a copy in a temp directory and substitute that on the command line. */ const char* tempfn; FILE* fromcopy; FILE* tocopy; int c2; fixexpansionlibrary: tempfn="%s.c"; (void) ick_snprintf_or_die(buf2, sizeof buf2, "%s.c", argv[optind]); fromcopy = ick_findandfopen(buf2,ick_cskeldir,"rb",argv[0]); if(!fromcopy) /* same error as for syslib */ ick_lose(IE127, 1, (const char*) NULL); #if __DJGPP__ /* Look for a temp directory to store a copy of the C file, the resulting .cio, .o files, etc. */ if(isenv("TMP")) tempfn="/dev/env/TMP/%s.c"; if(isenv("TEMP")) tempfn="/dev/env/TEMP/%s.c"; if(isenv("TMPDIR")) tempfn="/dev/env/TMPDIR/%s.c"; if(isenv("ICKTEMP")) tempfn="/dev/env/ICKTEMP/%s.c"; #else tempfn="/tmp/%s.c"; /* always valid on POSIX */ #endif /*@-formatconst@*/ /* all possibilities are fine */ (void) ick_snprintf_or_die(buf2, sizeof buf2, tempfn, argv[optind]); /*@=formatconst@*/ if((tocopy = fopen(buf2,"wb")) == NULL) ick_lose(IE888, 1, (const char*) NULL); for(;;) { c2=fgetc(fromcopy); if(c2==EOF) break; (void) fputc(c2,tocopy); } (void) fclose(fromcopy); (void) fclose(tocopy); /*@+onlytrans@*/ /* this is a memory leak that will need sorting out later, thus the explicit turn-warning-on */ argv[optind]=malloc(sizeof(buf2)+1); /*@=onlytrans@*/ if(!(argv[optind])) ick_lose(IE888, 1, (const char*) NULL); strcpy(argv[optind],buf2); *(strrchr(argv[optind],'.')) = '\0'; continue; } ick_lose(IE998, 1, (const char *)NULL); } *chp++ = '\0'; /* Beginning of block that figures out file type from extension. */ if(useickec && (!strcmp(chp,"c") || !strcmp(chp,"cio") || !strcmp(chp,"c99"))) /* AIS */ { if(firstfile != false) /* need exactly 1 INTERCAL file */ ick_lose(IE998, 1, (const char *)NULL); continue; /* don't process C or cio files further yet */ } if(useickec && !strcmp(chp,"a")) { /* AIS: request for a library. Given a filename of the form libwhatever.a, it adds -lwhatever to libbuf (that's with a preceding space). If the filename doesn't start with lib, it instead adds a space and the filename to libbuf. */ handle_archive(libbuf, sizeof libbuf, argv[optind] /* Archive name without extension. */); *argv[optind]='\0'; continue; } if(useickec && !strcmp(chp,"b98")) { handle_befunge98(libbuf, sizeof libbuf, libdir, argv[0], argv[optind] /* Filename without extension. */); /* Sort out the ecto_b98 expansion library. */ argv[optind] = "ecto_b98"; goto fixexpansionlibrary; } if(useickec && firstfile == false) /* AIS */ ick_lose(IE998, 1, (const char *)NULL); /* determine the file type from the extension */ /* AN: chp isn't used again after this it seems? */ find_intercal_base(chp); /* End of block that figures out file type from extension. */ /* zero out tuple and oblist storage */ treset(); politesse = 0; /* JH: default to no op-overusage and no computed come from */ opoverused = false; compucomesused = false; compucomecount = 0; gerucomesused = false; /* AIS: you forgot this one */ /* AIS: ensure that at least one variable exists, to prevent NULL pointers later on */ (void) intern(ick_ONESPOT, 1); /* mention .1 */ /* reset the lex/yacc environment */ if (!firstfile) { #ifdef NEED_YYRESTART yyrestart(stdin); #endif /* NEED_YYRESTART */ iyylineno = 1; } /* compile tuples from current input source */ (void) yyparse(); if(variableconstants) { /* AIS: Up to 4 extra meshes may be needed by feh.c. */ (void) intern(MESH, 0xFFFFFFFFLU); (void) intern(MESH, 0xFFFFLU); (void) intern(MESH, 0xAAAAAAAALU); (void) intern(MESH, 0x55555555LU); } /* * Miss Manners lives. */ if (ick_lineno > 2) { if (politesse == 0 || (ick_lineno - 1) / politesse >= 5) ick_lose(IE079, iyylineno, (const char *)NULL); else if (ick_lineno / politesse < 3) ick_lose(IE099, iyylineno, (const char *)NULL); } /* Check if we should auto add the system library. */ check_syslib(buf2, sizeof buf2, &needsyslib, argv[0], ick_sysdir); /* * 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. */ propagate_typeinfo(); codecheck(); /* check for compile-time errors */ /* AIS: And importantly, sort out line number references */ run_optimiser(); /* decide if and where to place the compiler bug */ bugline = randomise_bugline(); /* set up the generated C output file name */ (void) ick_snprintf_or_die(buf, sizeof buf, "%s.c", argv[optind]); /* Open output file. */ ofp = open_outfile(buf /* Output filename */); (void) fseek(ifp,0L,0); /* rewind skeleton file */ /* AIS: Before changing argv[0], locate coopt.sh. */ /* AN: Even though argv[0] isn't changed any more this breaks if moved out * of the per-file loop since ick_findandtestopen() returns a pointer to a * static buffer. Should be fixed. */ cooptsh = ick_findandtestopen("coopt.sh", ick_sysdir, "rb", argv[0]); /* AIS: and calculate yukcmdstr. */ (void) ick_snprintf_or_die(yukcmdstr, sizeof yukcmdstr, "%s%s" EXEEXT " %s %s", strchr(argv[optind],'/')||strchr(argv[optind],'\\')? "":"./",argv[optind],ick_sysdir,argv[0]); /* AIS: Remove the filename from argv[0], leaving only a directory. If this would leave it blank, change argv[0] to '.'. This is so gcc can find the includes/libraries the same way that ick_findandfreopen does. */ /* JH: use a copy of argv[0] for the path, to ensure argv[0] is * available for the next round */ strcpy(path,argv[0]); if(strchr(path,'/')) *(strrchr(path,'/')) = '\0'; else strcpy(path,"."); /* Generate the compiler command. */ gen_cc_command(buf2 /* output */, sizeof buf2, buf /* Source filename. */, includedir, path, libdir, argv[optind] /* Output binary filename. */); textlinecount=0; /* AIS: If there are no files, there's no need to free any textlines */ /* Generate code using ick-wrap.c (or pickwrap.c) */ generate_code(ifp, ofp, argv[optind] /* Source file name stem. */, &needsyslib, bugline, buf2 /* CC command. */); if(!outtostdout) (void) fclose(ofp); /* OK, now sic the C compiler on the results */ /* Also: if -y was given, run debugger */ run_cc_and_maybe_debugger(buf2, oldstdin, yukcmdstr, buf /* C file name */, argv[optind] /* Binary filename */); /* Run the constant-output optimizer (a form of post-processor). */ run_coopt(cooptsh, argv[optind]); } } /* Here ends the per-file loop. */ (void) fclose(ifp); if(!compile_only && useickec) /* AIS */ prelink(argc, argv, oldoptind, libdir, includedir, path, libbuf); /* AIS: Free malloc'd memory. */ if(textlines) { /* Marking what textlines points to as only would be the 'right' way to do this (because it is only), but I can't figure out the syntax to do it, so instead I'm supressing the warning that comes up because it isn't marked as only. */ /*@-unqualifiedtrans@*/ while(textlinecount--) free(textlines[textlinecount]); free(textlines); /*@=unqualifiedtrans@*/ } #ifdef HAVE_UNISTD_H (void) close(oldstdin); /* AIS */ #endif /* This point is the very end of the program. So it's correct for normal DO NOT FREE UNDER ANY CIRCUMSTANCES globals to be free at this point, so supressing the warning given as a result. */ /*@-globstate@*/ return 0; /*@=globstate@*/ } /* perpet.c ends here */ intercal-0.29/src/sizes.h0000644000175000017500000000037411435477314015233 0ustar brooniebroonie/* sizes.h -- constants defining the numeric base for INTERCAL variations */ extern int ick_Base; extern int ick_Small_digits; extern int ick_Large_digits; extern unsigned int ick_Max_small; extern unsigned int ick_Max_large; /* sizes.h ends here */ intercal-0.29/src/ick.h0000644000175000017500000001401211443403272014625 0ustar brooniebroonie/* ick.h -- compilation types for intercal parser */ #include "ick_bool.h" #ifdef ICKNOSEARCH #define ICKINCLUDEDIR "." #define ICKLIBDIR "." #define ICKBINDIR "." #define YYDEBUG 1 #endif /* AIS: This is now detected by autoconf and doesn't need to be set by the user. */ #ifdef NEED_YYRESTART # define USE_YYRESTART #endif #define YY_NO_UNPUT #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 (FROM - GETS + 1) * AIS: Changed this when I added new statements. */ #define MAXTYPES 32 /* AIS: Maximum supported spark/ears nesting, divided by 32. The value given allows for 3200 nested spark/ears groupings, which should be enough. */ #define SENESTMAX 100 enum onceagain {onceagain_NORMAL, onceagain_ONCE, onceagain_AGAIN}; /* AIS */ typedef struct node_t { int opcode; /* operator or type code */ unsigned long constant; /* constant data attached */ unsigned long optdata; /* AIS: Temp used by the optimizer */ int width; /* is this 32-bit data? */ struct node_t *lval, *rval; /* attached expression nodes */ struct node_t *nextslat; /* AIS: The next node with a slat */ } node; typedef struct tuple_t { unsigned int label; /* label # of this statement */ unsigned int ncomefrom; /* AIS: How many noncomputed COME FROMS have this line as a suck-point */ int exechance; /* chance of execution, initial abstain, (AIS) MAYBE details */ bool maybe; /* AIS: Where MAYBE details go when exechance has been parsed */ bool abstainable; /* AIS: Is it possible for this line to be abstained from? */ bool initabstain; /* AIS: Is this line initially abstained from? */ bool nextable; /* AIS: Can this line be a NEXT target? */ bool optversion; /* AIS: Use an optimized version? (Only set if the optimizer thinks that it's safe.) */ bool preproc; /* AIS: Is this line a nonexistent one that was added to implement a command in the parser? */ bool warn112:1; /* AIS: Should this line produce warning 112 during degeneration? */ bool warn128:1, warn534:1, warn018:1, warn016:1, warn276:1, warn239:1, warn622:1; /* AIS: As warn112. The warnings are a bitfield to save space. */ unsigned int type; /* statement type */ struct { /* AIS: Struct, not union needed because ABSTAIN expr FROM (line) has both */ unsigned int target; /* for NEXT statements */ node *node; /* attached expression node(s) */ } u; unsigned int nexttarget; /* AIS: The target tuple of a NEXT must also be recorded for optimizef */ int ick_lineno; /* source line for error messages */ bool sharedline; /* if NZ, two statements on a line */ enum onceagain onceagainflag; /* AIS: ONCE / AGAIN */ int ppnewtype; /* AIS: 'real' type of this line when the preprocessor is used; 0 on all statements but the 'real' statement */ signed setweave; /* AIS: +1 to turn weaving on, -1 to turn it off, before this command */ } tuple; /* this maps the `external' name of a variable to an internal ick_array index */ typedef struct { int type; unsigned long extindex; unsigned long intindex; int ignorable; /* AIS: Can this variable be IGNOREd? */ int memloc; /* AIS: Where does a PIC store this in memory? */ } atom; typedef struct { int value; /*@null@*/const char *name; } assoc; /*@null@*/ /*@owned@*/ /*@partial@*/ extern atom *oblist; /*@null@*/ /*@dependent@*/ /*@partial@*/ extern atom *obdex; extern int obcount, nonespots, ntwospots, ntails, nhybrids; extern int nmeshes; /* AIS */ /*@only@*/ extern tuple *tuples; extern int tuplecount; /*@dependent@*/ extern tuple *optuple; /* AIS: The tuple currently being optimized */ extern const char **enablers; /*@observer@*/ extern const char *enablersm1[MAXTYPES+1]; extern const assoc vartypes[]; /* the lexical analyzer keeps copies of the source logical lines */ /*@only@*/ extern char **textlines; extern int textlinecount; extern int iyylineno; /* AIS: These are needed to sort out a grammar near-ambiguity */ extern unsigned long sparkearsstack[SENESTMAX]; extern int sparkearslev; /* compilation options */ extern bool compile_only; /* just compile into C, don't run the linker */ extern bool nocompilerbug; /* set possibility of IE774 to zero */ extern bool ick_traditional; /* compile as INTERCAL-72 */ extern int yydebug; /* print debugging information while parsing */ extern int politesse; /* AIS: I added these */ extern bool yukdebug; /* debug the code with yuk */ extern bool yukprofile; /* profile the code with yuk */ extern int compucomecount; /* number of computed COME FROMs */ extern bool compucomesused; /* are computed COME FROMs used? */ extern bool nextfromsused; /* is NEXT FROM used? */ extern bool gerucomesused; /* is COME FROM gerund used? */ extern bool opoverused; /* is operand overloading used? */ extern bool useickec; /* are external calls used? */ extern bool createsused; /* are CREATEs used? */ /*@null@*/ extern node* firstslat; /* the ick_first node with a slat */ /*@null@*/ extern node* prevslat; /* the last node so far with a slat */ extern bool multithread; /* is the program multithreaded? */ extern bool variableconstants; /* is any assignment allowed? */ extern bool ick_coreonerr; /* dump core on IE778? */ extern int optdebug; /* debug the optimizer */ extern bool flowoptimize; /* optimize program flow */ extern bool ick_checkforbugs; /* check for bugs */ extern bool coopt; /* constant-output optimizer */ /* ick.h ends here */ intercal-0.29/src/baudot.bin0000644000175000017500000000021611435477314015670 0ustar brooniebroonie32 4 xxxedcba Ee3¢ Aa-+ Ss\Ii8#Uu7= Dd$*Rr4{Jj'~Nn,¥Ff!|Cc:^Kk(Ll2]HhYy6@Pp0Qq1£Oo9¬Bb?Gg&Mm.%Xx/_Vv;intercal-0.29/src/feh.h0000644000175000017500000000335411443403272014630 0ustar brooniebroonie/* feh.h -- compilation functions used by perpetrate.c and ick.y */ /*@partial@*/ extern node *newnode(void); /*@partial@*/ extern node *cons(int type, /*@null@*/ /*@keep@*/ node *car, /*@null@*/ /*@keep@*/ node *cdr); extern unsigned long intern(int type, unsigned long index); extern void checklabel(int label); extern void treset(void); /*@out@*/ /*@dependent@*/ extern tuple *newtuple(void); extern void tupleswap(int,int); /* AIS */ extern void ppinit(int); /* AIS */ extern void typecast(node *np); extern void codecheck(void); extern void optimize(node *np); /*@observer@*/ /*@null@*/ extern const char *nameof(int value, const assoc table[]); extern void emit(tuple *tn, FILE *fp); extern void emittextlines(FILE *fp); extern void emitslatproto(FILE *fp); /* AIS: emit prototypes for /-functions */ extern void emitslat(FILE* fp); /* AIS: emit bodies of /-functions */ extern int comefromsearch(tuple *tn, unsigned int index); /* AIS */ extern void explexpr(node* np, FILE* fp); /* AIS */ extern void prexpr(node *np, FILE* fp, int freenode); /* AIS: destaticed */ extern void checknodeactbits(node *np); /* AIS */ extern void optimizef(void); /* AIS */ extern void nodefree(/*@keep@*/ /*@null@*/ node* np); /* AIS */ extern unsigned long varextern(unsigned long intern, int vartype); /* AIS */ extern node *nodecopy(const node*); /* AIS */ extern bool nodessame(/*@observer@*/ const node*, /*@observer@*/ const node*); /* AIS */ extern node *optdebugnode; /* AIS */ extern const char **enablers; /* AIS: so that there can be an element before the ick_first element of the ick_array (UNKNOWN is element -1, just to cause a bit more confusion) */ extern const assoc vartypes[]; extern bool useprintflow; /* AIS */ /* feh.h ends here */ intercal-0.29/src/feh2.c0000644000175000017500000025220611443404360014706 0ustar brooniebroonie/**************************************************************************** Name feh2.c -- code-generator back-end for ick parser DESCRIPTION This module provides storage manglement and code degeneration for the INTERCAL compiler. Optimizations (formerly in this file) were split into dekludge.c. 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 "config.h" #include #include #include #include #include "sizes.h" #include "ick.h" #include "parser.h" #include "fiddle.h" #include "ick_lose.h" #include "feh.h" /* AIS: Destaticed for dekludge.c */ int emitlineno; /* line number for errors encountered during emit */ /*@-exportlocal@*/ /* the parser uses this */ bool mark112 = 0; /* AIS: Mark the ick_next generated tuple for W112 */ /*@=exportlocal@*/ /* AIS: From perpet.c */ extern bool pickcompile; extern bool ick_clcsemantics; /************************************************************************* * * Node allocation functions. * * Nodes are used to represent expression trees. The emit() function * deallocates them. * **************************************************************************/ /*@partial@*/ node *newnode(void) /* allocate and zero out a new expression node */ { node* temp; temp=calloc(sizeof(node), 1); if(!temp) ick_lose(IE345, 0, (const char*) NULL); return temp; } /*@partial@*/ node *cons(int type, /*@null@*/ /*@keep@*/ node *car, /*@null@*/ /*@keep@*/ 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 long intern(int type, unsigned long index) { atom *x; /* AIS: Allow use of a modifiable constant 0 or >65535. */ if ((index < 1LU || index > 65535LU) && type!=MESH) ick_lose(IE200, iyylineno, (const char *)NULL); /*@-branchstate@*/ if (!oblist) { /* initialize oblist and obdex */ oblist = malloc(ALLOC_CHUNK * sizeof(atom)); if (!oblist) ick_lose(IE345, iyylineno, (const char *)NULL); obdex = oblist; obcount = ALLOC_CHUNK; } else { /* 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); } /*@=branchstate@*/ assert(oblist != NULL); /* else we must intern a new symbol */ /* AIS: Splint doesn't understand what's going on here at all. Disabling the warnings; I've checked this and think it's correct. */ /*@-usedef@*/ /*@-usereleased@*/ /*@-branchstate@*/ if (obdex >= oblist + obcount) { obcount += ALLOC_CHUNK; x = realloc(oblist, obcount * sizeof(atom)); if (!x) ick_lose(IE333, iyylineno, (const char *)NULL); obdex = x + (obdex - oblist); oblist = x; } /*@=branchstate@*/ /*@=usereleased@*/ /*@=usedef@*/ obdex->type = type; obdex->extindex = index; obdex->memloc = 0; /* AIS: not placed in memory yet */ if (type == ick_ONESPOT) obdex->intindex = (unsigned)nonespots++; if (type == ick_TWOSPOT) obdex->intindex = (unsigned)ntwospots++; if (type == ick_TAIL) obdex->intindex = (unsigned)ntails++; if (type == ick_HYBRID) obdex->intindex = (unsigned)nhybrids++; if (type == MESH) /* AIS: count meshes too */ obdex->intindex = (unsigned)nmeshes++; ++obdex; /*@-usedef@*/ return(obdex[-1].intindex); /*@=usedef@*/ } /************************************************************************* * * This function insures a label is valid. * **************************************************************************/ /* AIS: I haven't modified this function, but I have repurposed it without changing the code; this function must not now have side effects (apart from an error exit), because some labels are initialised in the preprocessor without causing this. */ void checklabel(int label) { if (label < 1 || label > 65535) ick_lose(IE197, iyylineno, (const char *)NULL); } /************************************************************************* * * AIS: Search for the indexth COME_FROM sucking in the given tuple. * Return an int representing the COME_FROM's tn-tuples+1, or -1. * index is based at 1, not 0 as is usual for C. * ***************************************************************************/ int comefromsearch(tuple* tn, unsigned int index) { tuple* tp; for (tp = tuples; tp < tuples + ick_lineno; tp++) { if((tp->type == COME_FROM || tp->type == NEXTFROMLABEL) && tp->u.target == (unsigned)(tn-tuples+1)) index--; if(!index) return tp-tuples+1; } return -1; } /************************************************************************* * * Tuple allocation functions. * **************************************************************************/ void treset(void) { tuplecount = 0; if (tuples) { /* AIS: Splint doesn't understand lazy allocation, which is why it thinks I'm treating an unqualified as an only (I am, but a lazy list doesn't fit any of Splint's storage classes); also, I am completely destroying the tuples, because any nodes in them ought to have been deallocated in prexpr. */ /*@-unqualifiedtrans@*/ /*@-compdestroy@*/ free(tuples); tuples = NULL; /*@=unqualifiedtrans@*/ /*@=compdestroy@*/ } nmeshes = nonespots = ntwospots = ntails = nhybrids = 0; obdex = oblist; ick_lineno = 0; /* AIS: It's easier to mark tuples as 'always allocated', because it usually is, and just supress the warnings. Maybe the 'proper' way to do it would be to assert that tuples was non-null everywhere, but again this is just problems with Splint not understanding how lazy allocation works. So I tell Splint that it's allocated everywhere and just supress the warnings it produces when it isn't. */ /*@-globstate@*/ } /*@=globstate@*/ /*@out@*/ /*@dependent@*/ tuple *newtuple(void) /* allocate and zero out a new expression tuple */ { /* Patch by Joris Huizer: must leave at least 1 tuple empty */ if (ick_lineno >= tuplecount - 1 || tuples == NULL) { tuplecount += ALLOC_CHUNK; if (tuples) tuples = (tuple *)realloc(tuples, tuplecount * sizeof(tuple)); else tuples = (tuple *)malloc(tuplecount * sizeof(tuple)); if (!tuples) ick_lose(IE666, iyylineno, (const char *)NULL); memset(tuples + ick_lineno, 0, (tuplecount - ick_lineno) * sizeof(tuple)); } if(mark112) tuples[ick_lineno].warn112 = true; mark112 = false; /* AIS */ /* Yes, tuples is strictly speaking 'partial' at this point, but it's going to be filled in later, and isn't marked as partial due to it not being partial through most of the code, and you can't write out on a global. So instead I'm just suppressing the warning, because it doesn't lead to a problem long-term. */ /*@-compdef@*/ return(tuples + ick_lineno++); /*@=compdef@*/ } void tupleswap(int distback1, int distback2) { tuple temp; memcpy(&temp, &tuples[ick_lineno-distback1], sizeof(tuple)); memcpy(&tuples[ick_lineno-distback1], &tuples[ick_lineno-distback2], sizeof(tuple)); memcpy(&tuples[ick_lineno-distback2], &temp, sizeof(tuple)); /* Splint doesn't understand memcpy, and so falsely things this is a memory leak. */ /*@-compdestroy@*/ } /*@=compdestroy@*/ void ppinit(int tuplecount) { while(tuplecount) { /* 0 is an impossible exechance; make sure it's set for tuple elements. */ if(!tuples[ick_lineno-tuplecount].exechance) tuples[ick_lineno-tuplecount].exechance=100; /* The onceagainflag also needs to be set. */ tuples[ick_lineno-tuplecount].onceagainflag=onceagain_NORMAL; tuplecount--; } } /************************************************************************* * * 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. */ /*@-nullderef@*/ /* AIS: because the opcode defines whether lval or rval are nonnull */ if (np->opcode == MESH || np->opcode == ick_ONESPOT || np->opcode == ick_TAIL) np->width = 16; else if (np->opcode == ick_TWOSPOT || np->opcode == ick_HYBRID || np->opcode == MINGLE || np->opcode == MESH32 || np->opcode == UNKNOWNOP /* AIS */) 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 == INTERSECTION) /* AIS */ np->width = (np->rval ? np->lval ? np->rval->width == 16 ? np->lval->width : 32 : np->rval->width : np->lval ? np->lval->width : 32); else if (np->opcode == BADCHAR) /* AIS */ np->width = 16; else if (np->opcode == SUB) np->width = np->lval->width; /* type of the array */ else if (np->opcode == SLAT || np->opcode == BACKSLAT) np->width = np->lval->width; /* AIS: \ and / return their left arg */ /*@=nullderef@*/ } /************************************************************************* * * 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. * * AIS: codecheck has another important job, that of filling in information * about COME FROM suckpoints and ABSTAIN/REINSTATE command numbers * into the tuples. * **************************************************************************/ void codecheck(void) { tuple *tp, *up; int notpast1900; /* AIS */ /* check for assignment type mismatches */ /* This check can't be done at compile time---RTFM. [LHH] */ /* for (tp = tuples; tp < tuples + ick_lineno; tp++) if (tp->type == GETS) if (tp->u.node->lval->width == 16 && tp->u.node->rval->width == 32) ick_lose(IE275, tp - tuples + 1, (const char *)NULL); */ /* check for duplicate labels */ for (tp = tuples; tp < tuples + ick_lineno; tp++) if (tp->label) for (up = tuples; up < tuples + ick_lineno; up++) if (tp != up && tp->label == up->label) ick_lose(IE182, tp - tuples + 1, (const char *)NULL); /* * Check that every NEXT, ABSTAIN, REINSTATE and COME_FROM actually has a * legitimate target label. */ notpast1900 = 1; for (tp = tuples; tp < tuples + ick_lineno; tp++) { if (tp->label == 1900) notpast1900 = false; /* AIS */ if (tp->type == NEXT || tp->type == ABSTAIN || tp->type == REINSTATE || tp->type == COME_FROM || tp->type == FROM || tp->type == NEXTFROMLABEL) /* AIS: added FROM, NEXTFROMLABEL. */ { bool foundit = false; if (tp->u.target >= 1900 && tp->u.target <= 1998) { /* AIS: This program uses syslib.i's random number feature... or are we in syslib already? */ if(notpast1900) coopt = 0; } if (tp->u.target > 65535 && !tp->preproc) /* AIS */ ick_lose(IE197, tp - tuples + 1, (const char*) NULL); for (up = tuples; up < tuples + ick_lineno; up++) if (tp->u.target == up->label) { foundit = true; break; } if (!foundit) { /* AIS: Added the pickcompile check. Syslib has to be optimized for PICs, so syslib.i isn't imported and so none of the lables in it will appear in the program. Also added the useickec check, as that's another legitimate way for a NEXT to target a nonexistent line label */ if (tp->type == NEXT && !useickec && (!pickcompile||tp->u.target<1000||tp->u.target>1999)) ick_lose(IE129, tp - tuples + 1, (const char *)NULL); else if (tp->type == NEXT) /* AIS */ {tp->nexttarget=0; continue;} else if (useickec) /* AIS */ continue; /* AIS: NEXTFROMLABEL's basically identical to COME_FROM */ else if (tp->type == COME_FROM || tp->type == NEXTFROMLABEL) ick_lose(IE444, tp - tuples + 1, (const char *)NULL); else ick_lose(IE139, tp - tuples + 1, (const char *)NULL); } /* tell the other tuple if it is a COME FROM target */ /* AIS: NEXTFROMLABEL again */ else if (tp->type == COME_FROM || tp->type == NEXTFROMLABEL) { if (up->ncomefrom && !multithread) /* AIS: multithread check */ ick_lose(IE555, iyylineno, (const char *)NULL); else up->ncomefrom++; /* AIS: to handle multiple COME FROMs */ } /* this substitutes line numbers for label numbers AIS: COME FROM now uses this too. This changes the logic slightly so that an !foundit condition would fall through, but as long as ick_lose doesn't return, it's not a problem. (I removed the else before the if.) */ if (tp->type != NEXT) { /* AIS: added this useickec condition. */ if(!useickec || (tp->type!=NEXTFROMLABEL && tp->type!=COME_FROM)) tp->u.target = (unsigned)(up - tuples + 1); } else /* AIS */ { tp->nexttarget = (unsigned)(up - tuples + 1); up->nextable = true; } } } } /* AIS: Added the third argument to prexpr and prvar. It specifies whether the node should be freed or not. I added the third argument in all calls of prexpr/prvar. This protoype has been moved up through the file so it can be used earlier. Destaticed so it can be referenced by dekludge.c. */ void prexpr(node *np, FILE *fp, int freenode); /************************************************************************* * * 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 parser.y ever changes, * this will need to be reordered. */ /*@observer@*/ const char *enablersm1[MAXTYPES+1] = { "UNKNOWN", /* AIS: so comments can be ABSTAINED/REINSTATED */ "GETS", "RESIZE", "NEXT", "GO_AHEAD", /* AIS: Added for backtracking */ "GO_BACK", /* AIS: Added for backtracking */ "FORGET", "RESUME", "STASH", "RETRIEVE", "IGNORE", "REMEMBER", "ABSTAIN", "REINSTATE", "DISABLE", "ENABLE", "MANYFROM", /* AIS: Added ABSTAIN expr FROM gerunds */ "GIVE_UP", "READ_OUT", "WRITE_IN", "PIN", "COME_FROM", "NEXTFROMLABEL", /* AIS */ "NEXTFROMEXPR", /* AIS */ "NEXTFROMGERUND", /* AIS */ "COMPUCOME", /* AIS: Added COMPUCOME */ "GERUCOME", /* AIS: This is COME FROM gerunds */ "PREPROC", /* AIS: Nonexistent statement */ "WHILE", /* AIS: statement WHILE statement */ "TRY_AGAIN", /* AIS: Added TRY AGAIN */ "CREATE", /* AIS */ "COMPUCREATE", /* AIS */ "FROM", /* AIS: ABSTAIN expr FROM LABEL */ }; const char** enablers = enablersm1+1; const assoc vartypes[] = { { ick_ONESPOT, "ick_ONESPOT" }, { ick_TWOSPOT, "ick_TWOSPOT" }, { ick_TAIL, "ick_TAIL" }, { ick_HYBRID, "ick_HYBRID" }, { 0, (const char *)NULL } }; static const assoc forgetbits[] = { { ick_ONESPOT, "ick_oneforget" }, { ick_TWOSPOT, "ick_twoforget" }, { ick_TAIL, "ick_tailforget" }, { ick_HYBRID, "ick_hyforget" }, { 0, (const char *)NULL } }; /* AIS: Destatic. This is now needed in perpet.c. */ const assoc varstores[] = { { ick_ONESPOT, "ick_onespots" }, { ick_TWOSPOT, "ick_twospots" }, { ick_TAIL, "ick_tails" }, { ick_HYBRID, "ick_hybrids" }, { 0, (const char *)NULL } }; /* AIS: A demangled version */ static const assoc varstoresdem[] = { { ick_ONESPOT, "onespots" }, { ick_TWOSPOT, "twospots" }, { ick_TAIL, "tails" }, { ick_HYBRID, "hybrids" }, { 0, (const char *)NULL } }; static const assoc typedefs[] = { { ick_ONESPOT, "ick_type16" }, { ick_TWOSPOT, "ick_type32" }, { ick_TAIL, "ick_type16" }, { ick_HYBRID, "ick_type32" }, { 0, (const char *)NULL } }; /*@observer@*/ /*@null@*/ const char *nameof(int value, const assoc table[]) /* return string corresponding to value in table */ { const assoc *ap; for (ap = table; ap->name; ap++) if (ap->value == value) return(ap->name); return((const char *)NULL); } /* AIS: Code for printing explanations (mixed C/INTERCAL code that lets the user know what the meaning of an expression is). This is paraphrased from the prexpr/prvar code lower down. It's passed to yuk so that the explain ('e') command works. It's also included in the degenerated C code when the option -c is used, so the person looking at the code can debug both the INTERCAL and ick itself more effectively, and used by -h to produce its optimizer-debug output, and used to produce the variable numbers used in ick_createdata. */ unsigned long varextern(unsigned long intern, int vartype) { atom *x; if(!oblist) ick_lose(IE778, emitlineno, (const char*) NULL); for (x = oblist; x < obdex; x++) if (x->type == vartype && (unsigned long)x->intindex == intern) return(x->extindex); if(vartype==MESH) return 0; /* the mesh wasn't used after all */ ick_lose(IE778, emitlineno, (const char*) NULL); /*@-unreachable@*/ return 0; /*@=unreachable@*/ } static void explvar(node* np, FILE* fp) { node *sp; switch(np->opcode) { case ick_ONESPOT: (void) fprintf(fp, ".%lu", varextern(np->constant,ick_ONESPOT)); break; case ick_TWOSPOT: (void) fprintf(fp, ":%lu", varextern(np->constant,ick_TWOSPOT)); break; case ick_TAIL: (void) fprintf(fp, ",%lu", varextern(np->constant,ick_TAIL)); break; case ick_HYBRID: (void) fprintf(fp, ";%lu", varextern(np->constant,ick_HYBRID)); break; case SUB: (void) fprintf(fp, "("); explvar(np->lval, fp); (void) fprintf(fp, " SUB "); for (sp = np->rval ; sp ; sp = sp->rval) explexpr(sp->lval, fp); (void) fprintf(fp, ")"); break; default: ick_lose(IE778, emitlineno, (const char*) NULL); } } /* unlike prexpr, this doesn't free its operands */ void explexpr(node* np, FILE* fp) { if(!np) return; switch (np->opcode) { case MINGLE: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " $ "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case SELECT: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " ~ "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case UNKNOWNOP: (void) fprintf(fp, "("); explexpr(np->rval->lval, fp); if(np->lval->constant < 256) (void) fprintf(fp, " %c ", (char)np->lval->constant); else (void) fprintf(fp, " %c^H%c ", (char)(np->lval->constant / 256), (char)(np->lval->constant % 256)); explexpr(np->rval->rval, fp); (void) fprintf(fp, ")"); break; case SLAT: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " / "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case BACKSLAT: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " \\ "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case AND: (void) fprintf(fp, "(&%d ", np->width); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case OR: (void) fprintf(fp, "(V%d ", np->width); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case XOR: (void) fprintf(fp, "(?%d ", np->width); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case FIN: if (ick_Base < 3) ick_lose(IE997, emitlineno, (const char *)NULL); (void) fprintf(fp, "(^%d ", np->width); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case WHIRL: case WHIRL2: case WHIRL3: case WHIRL4: case WHIRL5: if (np->opcode - WHIRL + 3 > ick_Base) ick_lose(IE997, emitlineno, (const char *)NULL); if(np->opcode == WHIRL) (void) fprintf(fp, "(@%d ", np->width); else (void) fprintf(fp, "(%d@%d ", np->opcode - WHIRL + 1, np->width); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case MESH: if(variableconstants) /* AIS */ (void) fprintf(fp, "meshes[%lu]", np->constant); else (void) fprintf(fp, "0x%lx", np->constant); break; case MESH32: (void) fprintf(fp, "0x%lx", np->constant); break; case ick_ONESPOT: case ick_TWOSPOT: case ick_TAIL: case ick_HYBRID: case SUB: explvar(np, fp); break; /* cases from here down are generated by the optimizer */ case C_AND: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " & "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_OR: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " | "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_XOR: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " ^ "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_NOT: (void) fprintf(fp, "(~%d ", np->width); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_NOTEQUAL: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " != "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_A: (void) fprintf(fp, "a"); break; case C_RSHIFTBY: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " >> "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_LOGICALNOT: (void) fprintf(fp, "(! "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_LSHIFTBY: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " << "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_PLUS: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " + "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_MINUS: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " - "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_TIMES: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " * "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_DIVIDEBY: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " / "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_MODULUS: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " %% "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_GREATER: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " > "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_LESS: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " < "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_ISEQUAL: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " == "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_LOGICALAND: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " && "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case C_LOGICALOR: (void) fprintf(fp, "("); explexpr(np->lval, fp); (void) fprintf(fp, " || "); explexpr(np->rval, fp); (void) fprintf(fp, ")"); break; case INTERSECTION: explexpr(np->lval, fp); (void) fprintf(fp, " + "); explexpr(np->rval, fp); break; case GETS: case RESIZE: explexpr(np->lval, fp); (void) fprintf(fp, " <- "); explexpr(np->rval, fp); break; case BY: explexpr(np->lval, fp); (void) fprintf(fp, " BY "); explexpr(np->rval, fp); break; default: ick_lose(IE778, emitlineno, (const char*) NULL); /*@-unreachable@*/ break; /*@=unreachable@*/ } } /* AIS: Added the third argument to prexpr and prvar. It specifies whether the node should be freed or not. I added the third argument in all calls of prexpr/prvar. */ /* AIS: I moved prexpr's prototype higher in the file. Destaticed so the optimizer can access it. */ static void prvar(node *np, FILE *fp, int freenode) /* print out args to pass to storage manager for reference */ { node *sp; int dim; switch (np->opcode) { case ick_ONESPOT: (void) fprintf(fp, "ick_onespots[%lu]", np->constant); break; case ick_TWOSPOT: (void) fprintf(fp, "ick_twospots[%lu]", np->constant); break; case ick_TAIL: (void) fprintf(fp, "ick_TAIL, &ick_tails[%lu]", np->constant); break; case ick_HYBRID: (void) fprintf(fp, "ick_HYBRID, &ick_hybrids[%lu]", np->constant); break; case SUB: { (void) fprintf(fp, "ick_aref("); prvar(np->lval, fp, freenode); 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, freenode); } (void) fprintf(fp, ")"); } break; default: /* Added by AIS */ ick_lose(IE778, emitlineno, (const char*) NULL); /*@-unreachable@*/ break; /*@=unreachable@*/ } } static void ooprvar(node *np, FILE *fp, int freenode) /* AIS: Print out the overloaded version */ { node *sp; int dim; switch (np->opcode) { case ick_ONESPOT: (void) fprintf(fp, "ick_oo_onespots[%lu]", np->constant); break; case ick_TWOSPOT: (void) fprintf(fp, "ick_oo_twospots[%lu]", np->constant); break; case ick_TAIL: case ick_HYBRID: /* This should never be reached */ ick_lose(IE778, emitlineno, (const char*) NULL); /*@-unreachable@*/ break; /*@=unreachable@*/ case SUB: { (void) fprintf(fp, "ick_aref("); prvar(np->lval, fp, freenode); 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, freenode); } (void) fprintf(fp, ")"); } break; default: ick_lose(IE778, emitlineno, (const char*) NULL); /*@-unreachable@*/ break; /*@=unreachable@*/ } } /* AIS: Give us a mesh with value x */ static unsigned long meshval(unsigned long x) { if(variableconstants) return intern(MESH, x); else return x; } /* AIS: This is the reverse of prexpr, in a way. It degenerates an expression that causes *np to become equal to *target. If this is impossible at any point, it degenerates code that causes error 277 (and itself causes error 278 if the situation is inevitable). As for the annotations; there quite possibly are memory allocation mistakes here, but just about every line is a false positive (because we're operating at the subobject level in terms of copy/free/allocate) for Splint, and so disabling the warnings doesn't make the output any less useful. (When there are so many false positives, disabling the true positives doesn't make them any harder to find by eye. */ /*@-temptrans@*/ /*@-kepttrans@*/ /*@-compdestroy@*/ /*@-branchstate@*/ /*@-nullpass@*/ static void revprexpr(node *np, FILE *fp, node *target) { node* temp; switch (np->opcode) { case MINGLE: /* We can use select to determine what np->lval and np->rval have to become equal to, as long as we're in base 2. */ if(ick_Base!=2) { fprintf(fp, " ick_lose(IE277, ick_lineno, (const char*) NULL);\n"); ick_lwarn(W278, emitlineno, (const char*) NULL); break; } temp=cons(MESH,0,0); temp->constant=meshval(0xAAAAAAAALU); temp->width=32; temp=cons(SELECT,target,temp); temp->width=target->width; revprexpr(np->lval, fp, temp); free(temp->rval); free(temp); temp=cons(MESH,0,0); temp->constant=meshval(0x55555555LU); temp->width=32; temp=cons(SELECT,target,temp); temp->width=target->width; revprexpr(np->rval, fp, temp); free(temp->rval); free(temp); break; case SELECT: /* Set the left of the select to the target, and the right to 0xffffffff or 0xffff. This only works in base 2. */ if(ick_Base!=2) { fprintf(fp, " ick_lose(IE277, ick_lineno, (const char*) NULL);\n"); ick_lwarn(W278, emitlineno, (const char*) NULL); break; } temp=cons(MESH,0,0); temp->constant=meshval(target->width==32?0xFFFFFFFFLU:0xFFFFLU); temp->width=target->width; revprexpr(np->lval, fp, target); revprexpr(np->rval, fp, temp); free(temp); break; case UNKNOWNOP: /* don't be silly */ fprintf(fp, " ick_lose(IE277, ick_lineno, (const char*) NULL);\n"); ick_lwarn(W278, emitlineno, (const char*) NULL); break; case BACKSLAT: /* Unimplemented. This isn't even in the parser yet, so it's a ick_mystery how we got here. */ ick_lose(IE778, emitlineno, (const char*) NULL); /*@-unreachable@*/ break; /*@=unreachable@*/ case SLAT: /* We need to set the true value of the LHS... */ /* Copied and modified from the GETS code */ if(!pickcompile) { (void) fprintf(fp," (void) ick_assign((char*)&"); prvar(np->lval, fp, 0); (void) fprintf(fp,", %s", nameof(np->lval->opcode, vartypes)); (void) fprintf(fp,", %s[%lu], ", nameof(np->lval->opcode, forgetbits), np->lval->constant); prexpr(target, fp, 0); (void) fprintf(fp,"); \n"); } else /* AIS: Added this case for the simpler PIC assignment rules */ { (void) fprintf(fp,"\t""if(ignore%s%lu) ", nameof(np->lval->opcode,varstores), np->lval->constant); prexpr(np->lval, fp, 0); (void) fprintf(fp, " = "); prexpr(target, fp, 0); (void) fprintf(fp, "; \n"); } /* ... and we need to cause overloading to happen. This is a copy of part of the code for SLAT, modified to work in this context. */ ooprvar(np->lval, fp, 0); /* Do something highly non-portable with pointers that should work anyway. Each pointer needs to be given a unique code; so we use the hex representation of np casted to an unsigned long. Technically speaking, np->rval could be casted to anything; but all implementations I've ever seen cast unique pointers to unique numbers, which is good enough for our purposes. */ (void) fprintf(fp, ".get=ick_og%lx;\n ", (unsigned long)np->rval); ooprvar(np->lval, fp, 0); (void) fprintf(fp, ".set=ick_os%lx;\n", (unsigned long)np->rval); break; case AND: case OR: case XOR: case FIN: case WHIRL: case WHIRL2: case WHIRL3: case WHIRL4: case WHIRL5: temp=cons(np->opcode-AND+REV_AND,0,target); temp->width=temp->rval->width=np->width; revprexpr(np->rval, fp, temp); free(temp); break; case MESH: if(!variableconstants) { /* Can't set a mesh in this case */ fprintf(fp, " ick_lose(IE277, ick_lineno, (const char*) NULL);\n"); ick_lwarn(W278, emitlineno, (const char*) NULL); break; } (void) fprintf(fp," meshes[%lu] = ",np->constant); prexpr(target, fp, 0); (void) fprintf(fp,";\n"); break; case ick_ONESPOT: case ick_TWOSPOT: case ick_TAIL: case ick_HYBRID: case SUB: /* Copy the code for the GETS statement; this is almost the same thing. Modified because we're assigning target to np, not np->lval to np->rval, and to not free(). */ if(opoverused&& (np->opcode==ick_ONESPOT||np->opcode==ick_TWOSPOT)) /* AIS */ { (void) fprintf(fp," "); ooprvar(np, fp, 0); (void) fprintf(fp,".set("); prexpr(target, fp, 0); (void) fprintf(fp,",os%dspot%lu);\n", ((np->opcode==ick_TWOSPOT)?1:0)+1, np->constant); } else if(!pickcompile) { node* sp; if (np->opcode != SUB) { sp = np; (void) fprintf(fp," (void) ick_assign((char*)&"); } else { sp = np->lval; (void) fprintf(fp," (void) ick_assign("); } prvar(np, fp, 0); (void) fprintf(fp,", %s", nameof(sp->opcode, vartypes)); (void) fprintf(fp,", %s[%lu], ", nameof(sp->opcode, forgetbits), sp->constant); prexpr(target, fp, 0); (void) fprintf(fp,");\n"); } else /* AIS: Added this case for the simpler PIC assignment rules */ { (void) fprintf(fp," if(ignore%s%lu) ", nameof(np->opcode,varstores), np->constant); prexpr(np, fp, 0); (void) fprintf(fp, " = "); prexpr(target, fp, 0); (void) fprintf(fp, ";\n"); } break; /* cases from here down are generated by the optimizer, and so should never come up here and are errors. The exception is C_A, which should only ever appear in a target expression, so is also an error. */ case MESH32: case C_AND: case C_OR: case C_XOR: case C_NOT: case C_NOTEQUAL: case C_A: case C_RSHIFTBY: case C_LOGICALNOT: case C_LSHIFTBY: case C_PLUS: case C_MINUS: case C_TIMES: case C_DIVIDEBY: case C_MODULUS: case C_GREATER: case C_LESS: case C_ISEQUAL: case C_LOGICALAND: case C_LOGICALOR: case GETS: /* should never come up */ default: ick_lose(IE778, emitlineno, (const char*) NULL); /*@-unreachable@*/ break; /*@=unreachable@*/ } } /*@=temptrans@*/ /*@=kepttrans@*/ /*@=compdestroy@*/ /*@=branchstate@*/ /*@observer@*/ static char* E000string; /* AIS */ static int prunknownstr(node*, FILE*); /* AIS */ /* AIS: Destaticed */ /* Splint doesn't understand the concept of a function which might or might not free its argument. That's a pity, because its checking would come in useful here, but as it is we have to annotate memory checking off for this function. */ /*@-temptrans@*/ /*@-onlytrans@*/ /*@-compdestroy@*/ /*@-branchstate@*/ void prexpr(node *np, FILE *fp, int freenode) /* print out C-function equivalent of an expression */ { int tempint; switch (np->opcode) { case MINGLE: (void) fprintf(fp, "ick_mingle("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, ", "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case SELECT: (void) fprintf(fp, "ick_iselect("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, ", "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case UNKNOWNOP: /* AIS */ if(!useickec || !createsused) { /* CREATEd operators require -ea */ (void) fprintf(fp, "(ick_lose(IE000, ick_lineno, \"%s\"),0)", E000string); break; } /* We need to do the same as UNKNOWN statements, but as an expression. This is achieved with the helper function ick_dounop in ick_ec.c. */ (void) fprintf(fp, "ick_dounop(\""); (void) prunknownstr(np->lval, fp); if(freenode) free(np->lval); (void) fprintf(fp, "\", "); prexpr(np->rval->lval, fp, 0); (void) fprintf(fp, ", "); prexpr(np->rval->rval, fp, 0); (void) fprintf(fp, ", ick_lineno, %luUL, %luUL, %luUL" ", ick_og%lx, ick_og%lx, og2spot%lu" ", ick_os%lx, ick_os%lx, os2spot%lu, \"%s\")", intern(ick_TWOSPOT, 1601), intern(ick_TWOSPOT, 1602), intern(ick_TWOSPOT, 1603), (unsigned long) np->rval->lval, (unsigned long) np->rval->rval, intern(ick_TWOSPOT, 1603), (unsigned long) np->rval->lval, (unsigned long) np->rval->rval, intern(ick_TWOSPOT, 1603), E000string); if(freenode) free(np->rval); break; case BACKSLAT: /* AIS */ /* Unimplemented. This isn't even in the parser yet, so it's a ick_mystery how we got here. */ ick_lose(IE778, emitlineno, (const char*) NULL); /*@-unreachable@*/ break; /*@=unreachable@*/ case SLAT: /* AIS */ (void) fprintf(fp,"(("); ooprvar(np->lval, fp, 0); /* Do something highly non-portable with pointers that should work anyway. Each pointer needs to be given a unique code; so we use the hex representation of np casted to an unsigned long. Technically speaking, np->rval could be casted to anything; but all implementations I've ever seen cast unique pointers to unique numbers, which is good enough for our purposes. */ (void) fprintf(fp, ".get=ick_og%lx),(", (unsigned long)np->rval); ooprvar(np->lval, fp, 0); (void) fprintf(fp, ".set=ick_os%lx),(", (unsigned long)np->rval); prvar(np->lval, fp, freenode); /* np->rval will be freed later, when its expression is printed */ (void) fprintf(fp, "))"); return; /* mustn't be freed */ case AND: (void) fprintf(fp, "ick_and%d(", np->width); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case OR: (void) fprintf(fp, "ick_or%d(", np->width); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case XOR: (void) fprintf(fp, "ick_xor%d(", np->width); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case FIN: if (ick_Base < 3) ick_lose(IE997, emitlineno, (const char *)NULL); (void) fprintf(fp, "ick_fin%d(", np->width); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case WHIRL: case WHIRL2: case WHIRL3: case WHIRL4: case WHIRL5: if (np->opcode - WHIRL + 3 > ick_Base) ick_lose(IE997, emitlineno, (const char *)NULL); (void) fprintf(fp, "ick_whirl%d(%d, ", np->width, np->opcode - WHIRL + 1); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; /* AIS: Reversed operations */ case REV_AND: (void) fprintf(fp, "ick_rev_and%d(", np->width); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case REV_OR: (void) fprintf(fp, "ick_rev_or%d(", np->width); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case REV_XOR: (void) fprintf(fp, "ick_rev_xor%d(", np->width); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case REV_FIN: if (ick_Base < 3) ick_lose(IE997, emitlineno, (const char *)NULL); (void) fprintf(fp, "rev_fin%d(", np->width); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case REV_WHIRL: case REV_WHIRL2: case REV_WHIRL3: case REV_WHIRL4: case REV_WHIRL5: if (np->opcode - WHIRL + 3 > ick_Base) ick_lose(IE997, emitlineno, (const char *)NULL); (void) fprintf(fp, "rev_whirl%d(%d, ", np->width, np->opcode - WHIRL + 1); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case MESH: if(variableconstants) /* AIS */ (void) fprintf(fp, "meshes[%lu]", np->constant); else (void) fprintf(fp, "0x%lx", np->constant); break; case MESH32: (void) fprintf(fp, "0x%lx", np->constant); break; case ick_ONESPOT: case ick_TWOSPOT: case ick_TAIL: case ick_HYBRID: if(!opoverused||np->opcode==ick_TAIL||np->opcode==ick_HYBRID) prvar(np, fp, freenode); else /* AIS */ { ooprvar(np, fp, freenode); fprintf(fp, ".get("); prvar(np, fp, freenode); fprintf(fp,")"); } break; case SUB: (void) fprintf(fp, "*(%s*)", nameof(np->lval->opcode, typedefs)); prvar(np, fp, freenode); break; /* cases from here down are generated by the optimizer */ case C_AND: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " & "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_OR: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " | "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_XOR: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " ^ "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_NOT: (void) fprintf(fp, "(~"); tempint=np->width; /* AIS */ prexpr(np->rval, fp, freenode); if (tempint == ick_Small_digits) (void) fprintf(fp, " & ick_Max_small)"); else (void) fprintf(fp, " & ick_Max_large)"); break; /* AIS: I added the rest of the cases */ case C_NOTEQUAL: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " != "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_A: (void) fprintf(fp, "a"); break; case C_RSHIFTBY: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " >> "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_LOGICALNOT: (void) fprintf(fp, "(!"); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_LSHIFTBY: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " << "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_PLUS: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " + "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_MINUS: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " - "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_TIMES: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " * "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_DIVIDEBY: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " / "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_MODULUS: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " %% "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_GREATER: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " > "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_LESS: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " < "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_ISEQUAL: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " == "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_LOGICALAND: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " && "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case C_LOGICALOR: (void) fprintf(fp, "("); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " || "); prexpr(np->rval, fp, freenode); (void) fprintf(fp, ")"); break; case GETS: /* AIS: this is used only if freenode == 0 */ if(freenode) ick_lose(IE778, emitlineno, (const char*) NULL); prexpr(np->lval, fp, freenode); (void) fprintf(fp, " = "); prexpr(np->rval, fp, freenode); break; default: /* Added by AIS */ if(!freenode) break; /* Be less careful when not freeing, because this is used by -hH to print out its intermediate optimization stages */ ick_lose(IE778, emitlineno, (const char*) NULL); /*@-unreachable@*/ break; /*@=unreachable@*/ } if(freenode) (void) free(np); } /*@=temptrans@*/ /*@=onlytrans@*/ /*@=compdestroy@*/ /*@=branchstate@*/ /* By AIS: Helper function for prunknown */ static int prunknownstr(node *np, FILE* fp) { int i; switch(np->opcode) { case INTERSECTION: i=prunknownstr(np->lval, fp); i+=prunknownstr(np->rval, fp); return i; case BADCHAR: if (np->constant > 256) (void) fprintf(fp, "o%xx%x", (unsigned int)(np->constant / 256), (unsigned int)(np->constant % 256)); else (void) fprintf(fp, "u%x", (unsigned int)np->constant); return 2; case US_ID: (void) fputc((char)np->constant, fp); return 0; case US_ELEM: (void) fputc(';', fp); return 1; case US_SCALAR: (void) fputc('.', fp); return 1; case US_ARRVAR: (void) fputc(',', fp); return 1; case US_EXPR: (void) fputc('~', fp); return 1; default: ick_lose(IE778, emitlineno, (const char*) NULL); } /*@-unreachable@*/ return 0; /*@=unreachable@*/ } /* By AIS: Helper function for prunknown */ static void prunknowncreatedata(node *np, FILE* fp) { unsigned long ve; switch(np->opcode) { case INTERSECTION: prunknowncreatedata(np->lval, fp); prunknowncreatedata(np->rval, fp); return; case US_ID: return; /* nothing to do */ case US_SCALAR: ve=varextern(np->rval->constant,np->rval->opcode); fprintf(fp,"\t\t{%d,0,%lu,",np->rval->width,ve); break; case US_ARRVAR: /* an array doesn't itself have a value */ ve=varextern(np->rval->constant,np->rval->opcode); fprintf(fp,"\t\t{%d,1,%lu,{ick_ieg277,ick_ies277},0},\n", np->rval->width,ve); return; case US_ELEM: /* these two cases are actually treated the same way, */ case US_EXPR: /* because expressions can be assigned to */ fprintf(fp,"\t\t{%d,0,0,",np->rval->width); break; default: ick_lose(IE778, emitlineno, (const char*) NULL); } if(createsused) fprintf(fp,"{ick_og%lx,ick_os%lx},", (unsigned long)np->rval,(unsigned long)np->rval); else fprintf(fp,"{0,0},"); prexpr(np->rval,fp,0); fprintf(fp,"},\n"); } /* This function by AIS. Print a check to see if a just-in-case compiled statement actually has a meaning yet, or if we should error. */ static void prunknown(node *np, FILE* fp) { static long negcounter=-65538; int i,j; fprintf(fp,"\tif((ick_skipto=ick_jicmatch(\""); i=prunknownstr(np, fp); fprintf(fp, "\")))\n\t{\n\t ick_createdata icd[]={\n"); prunknowncreatedata(np, fp); fprintf(fp, "\t };\n"); if(createsused) { j=i; while(j--) (void) fprintf(fp, "\t\t""ICKSTASH(ick_TWOSPOT, %lu, " "ick_twospots, ick_oo_twospots);\n" "\t\t""ick_oo_twospots[%lu]=icd[%d].accessors;\n", intern(ick_TWOSPOT,(unsigned long)(1601+j)), intern(ick_TWOSPOT,(unsigned long)(1601+j)),j); } if(useickec) { fprintf(fp,"\t\t""ick_global_createdata=icd;\n"); fprintf(fp,"\t\t""ick_dogoto(ick_skipto,ick_lineno,1);\n"); } else { fprintf(fp,"\t\t""ick_pushnext(%ld); ick_skipto=-ick_skipto; goto top; " "case %ld:;\n",negcounter,negcounter); negcounter--; } if(createsused) { j=i; while(j--) (void) fprintf(fp, "\t\t""ICKRETRIEVE(ick_twospots, %lu, " "ick_TWOSPOT, ick_twoforget, ick_oo_twospots);\n", intern(ick_TWOSPOT,(unsigned long)(1601+j))); } fprintf(fp, "\t} else\n"); } /*@dependent@*/ 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) { (*cp++) = '.'; (*cp++) = '.'; (*cp++) = '.'; *cp = '\0'; return buf; } if (i) { (*cp++) = '\\'; (*cp++) = 'n'; (*cp++) = '\\'; (*cp++) = '\n'; (*cp++) = '\t'; } for (text = texts[i] ; text != NULL && *text != '\0'; cp++, text++) { if (cp>buf+MAXNICEBUF-10) { (*cp++) = '.'; (*cp++) = '.'; (*cp++) = '.'; *cp = '\0'; return buf; } if(*text == '"' || *text == '\\') { (*cp++) = '\\'; } if(*text == 'K') /* AIS: break the string so that the ick_ec preprocessor doesn't trigger on the string ICKNUMBERPAIR */ { (*cp++) = '"'; (*cp++) = '"'; } *cp = *text; } } *cp = '\0'; return buf; } static void emit_guard(tuple *tn, FILE *fp) /* emit execution guard for giiven tuple (note the unbalanced trailing {!) */ { if(tn->maybe) /* AIS */ { if(!multithread) ick_lose(IE405, emitlineno, (const char *)NULL); (void) fprintf(fp, " gonebackto = setjmp(btjb); choicepoint();\n"); } if(!flowoptimize || tn->abstainable) /* This condition by AIS */ { (void) fprintf(fp, " if ("); if (tn->maybe) /* AIS */ (void) fprintf(fp, "gonebackto == !("); if (tn->exechance < 100) (void) fprintf(fp, "ick_roll(%d) && ", tn->exechance); if ((tn->type != NEXT && tn->type != GO_BACK && tn->type != COME_FROM && /* AIS */ tn->type != NEXTFROMLABEL && tn->type != UNKNOWN) || tn->onceagainflag == onceagain_NORMAL) (void) fprintf(fp, "!ICKABSTAINED(%d))%s {\n", (int)(tn - tuples), /* AIS */ tn->maybe?")":""); else /* AIS: [NEXT, GO_BACK, COME_FROM] ONCE needs specially handled abstentions */ (void) fprintf(fp, "!ick_oldabstain)%s {\n", /* AIS */ tn->maybe?")":""); } else { /* AIS */ if(tn->maybe) ick_lose(IE778, emitlineno, (const char*) NULL); if(!tn->initabstain) { if(tn->type != COMPUCOME && tn->type != GERUCOME && tn->type != NEXTFROMEXPR && tn->type != NEXTFROMGERUND) (void) fprintf(fp, " {\n"); else (void) fprintf(fp, " if(1) {\n"); /* COMPUCOME specifically needs an if() so it can have an else. */ } else (void) fprintf(fp, " if(0) {\n"); /* for exceptional cases like DON'T COME FROM #1 where we need a label or an else. */ } } void emittextlines(FILE *fp) { int i=0; /* The first textline is line 1 */ (void) fprintf(fp, "\"\",\n"); while(++iick_lineno); if (tn->label) { if(!useickec) /* AIS */ (void) fprintf(fp, "case -%u: ; L%u:\n", tn->label, tn->label); else /* AIS: start one of ick_ec's labeled blocks. */ (void) fprintf(fp, "ick_labeledblock(%uU,{",tn->label); } if (yydebug || cdebug || compile_only) { (void) fprintf(fp, "\t""/* %s */", textlines[tn->ick_lineno]); /* AIS: grind out an expression explanation */ if (tn->type == GETS || tn->type == FORGET || tn->type == RESUME || tn->type == FROM || tn->type == COMPUCOME || tn->type == MANYFROM || tn->type == NEXTFROMEXPR) { (void) fprintf(fp, "\n\t/* Expression is "); explexpr(tn->type == MANYFROM ? tn->u.node->lval : tn->type == GETS ? tn->u.node->rval : tn->u.node, fp); (void) fprintf(fp, " */"); } } (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 + ick_lineno; up++) if (tn->u.target == up->label) { emitlineno = up->ick_lineno; break; } } else if (tn->ncomefrom) { /* AIS: For multithreading. Return the 1st if we're forking. */ emitlineno = comefromsearch(tn,1); if(emitlineno != -1) emitlineno = tuples[emitlineno-1].ick_lineno; } else if (tn < tuples + ick_lineno - 1) emitlineno = tn[1].ick_lineno; else emitlineno = iyylineno; if(!pickcompile) /* AIS: PICs can't report errors, so don't bother with ick_lineno */ (void) fprintf(fp, " ick_lineno = %d;\n", emitlineno); /* AIS: figure out which line we're on, so E000 can be done correctly */ if (tn < tuples + ick_lineno - 1) dim = tn[1].ick_lineno - tn->ick_lineno; else dim = iyylineno - tn->ick_lineno; if (tn->sharedline) ++dim; E000string=nice_text(textlines + tn->ick_lineno, dim); /* AIS: set weaving status if necessary */ if(tn->setweave) (void) fprintf(fp, " weaving = %d;\n", (tn->setweave>0)?1:0); /* AIS: print warnings on -l */ if(ick_checkforbugs) { if(tn->warn112) ick_lwarn(W112, emitlineno, (const char*) NULL); if(tn->warn128) ick_lwarn(W128, emitlineno, (const char*) NULL); if(tn->warn534) ick_lwarn(W534, emitlineno, (const char*) NULL); if(tn->warn018) ick_lwarn(W018, emitlineno, (const char*) NULL); if(tn->warn016) ick_lwarn(W016, emitlineno, (const char*) NULL); if(tn->warn276) ick_lwarn(W276, emitlineno, (const char*) NULL); if(tn->warn239) ick_lwarn(W239, emitlineno, (const char*) NULL); if(tn->warn622) ick_lwarn(W622, emitlineno, (const char*) NULL); } /* AIS: emit debugging information */ if (yukdebug||yukprofile) { (void) fprintf(fp, " YUK(%d,%d);\n", (int)(tn-tuples),emitlineno); } /* AIS: The +mystery option on degenerated code causes the code to unexpectedly terminate after 4 billion commands are run, thus preventing an infinite loop. Of course, it will enhance the fun if we don't tell the user that. (This is necessary for the constant-output optimizer to work properly.) */ if(coopt) (void) fprintf(fp, " ick_MYSTERYLINE;\n"); /* AIS: If the tuple is ONCE/AGAIN flagged, we need a delayed-action set of its abstention status to the AGAIN-flagged status. The problem is that some statements, like COME FROM, need to set after the command has finished, and some, like NEXT, need it before the command has started. At the moment, only NEXT and GO_BACK have a ONCE/AGAIN before it, rather than after (because neither of them continue in the normal fashion). UNKNOWN is also handled this way, because CREATEd statements can be NEXT-like but not COME FROM-like. */ if ((tn->type == NEXT || tn->type == GO_BACK || tn->type == UNKNOWN) && tn->onceagainflag != onceagain_NORMAL) { /* ONCE/AGAIN has already been swapped by perpet.c in the case of a preabstained statement ('DO NOT'...). So if we currently have a ONCE, it means that being abstained is the attractive state, and if we currently have an AGAIN, it means that being reinstated is the attractive state. Semantics with computed ABSTAIN: Don't change the abstention count unless necessary, in which case change it to 0 or 1. */ fprintf(fp," ick_oldabstain = ICKABSTAINED(%d);\n", (int)(tn - tuples)); fprintf(fp," ICKABSTAINED(%d) = %s;\n", (int)(tn - tuples), tn->onceagainflag==onceagain_ONCE ? "ick_oldabstain ? ick_oldabstain : 1" : "0"); /* This test-and-set must be atomic. As all statements are atomic anyway in the current version of ick, that isn't a problem, but if anyone wants to try using POSIX's multithreading features, the above two lines need to be a critical section. */ } /* AIS: in the case of COMPUCOME, we need an extra guard unless useickec. */ if ((!useickec && (tn->type == COMPUCOME || tn->type == NEXTFROMEXPR)) || tn->type == GERUCOME || tn->type == NEXTFROMGERUND) { fprintf(fp," if(0)\n {\n"); fprintf(fp,"CCF%d:\n",compucomecount++); if(tn->type == COMPUCOME || tn->type == NEXTFROMEXPR) { fprintf(fp," if(ick_skipto&&ick_skipto=="); prexpr(tn->u.node, fp, 1); } else if(tn->type == GERUCOME || tn->type == NEXTFROMGERUND) { fprintf(fp," if("); for (np = tn->u.node; np; np = np->rval) { if (np->constant == ABSTAIN) { (void) fprintf(fp, "linetype[truelineno] == %s || linetype[truelineno] == %s || " "linetype[truelineno] == %s || linetype[truelineno] == %s || ", enablers[np->constant-GETS], enablers[np->constant-GETS+2], enablers[FROM-GETS], enablers[MANYFROM-GETS]); } else if (np->constant == REINSTATE) { (void) fprintf(fp, "linetype[truelineno] == %s || linetype[truelineno] == %s || ", enablers[np->constant-GETS], enablers[np->constant-GETS+2]); } else if (np->constant == GETS) { (void) fprintf(fp, "linetype[truelineno] == %s || linetype[truelineno] == %s || ", enablers[GETS-GETS], enablers[RESIZE-GETS]); } else if (np->constant == COME_FROM) { (void) fprintf(fp, "linetype[truelineno] == %s || linetype[truelineno] == %s || " "linetype[truelineno] == %s || ", enablers[COME_FROM-GETS], enablers[COMPUCOME-GETS], enablers[GERUCOME-GETS]); } else if (np->constant == NEXTFROMLABEL) { (void) fprintf(fp, "linetype[truelineno] == %s || linetype[truelineno] == %s || " "linetype[truelineno] == %s || ", enablers[NEXTFROMLABEL-GETS], enablers[NEXTFROMEXPR-GETS], enablers[NEXTFROMGERUND-GETS]); } else { (void) fprintf(fp, "linetype[truelineno] == %s || ", enablers[np->constant-GETS]); } } fprintf(fp, "0"); } fprintf(fp,") {\n"); } /* AIS: With this block placed here, you can't even have a comment after a TRY AGAIN line. Move it below the next check if this seems to be undesirable behaviour. */ if(pasttryagain) /* AIS */ { ick_lose(IE993, emitlineno, (const char*)NULL); } if(flowoptimize && tn->initabstain && !tn->abstainable && tn->type != COMPUCOME && tn->type != COME_FROM && tn->type != NEXT && tn->type != GERUCOME && tn->type != NEXTFROMLABEL && tn->type != NEXTFROMEXPR && tn->type != NEXTFROMGERUND) /* AIS */ goto skipcomment; /* Look, a comment! We can completely skip all degeneration of this statement (although with -c, comments will appear in the degenerated code in its place). The COMPUCOME condition is because it is so weird. COME_FROM and NEXT are exempted so labels are generated. */ /* emit conditional-execution prefixes */ /* AIS: added the useickec condition */ if ((tn->type != COME_FROM && tn->type != NEXTFROMLABEL) || useickec) emit_guard(tn, fp); /* now emit the code for the statement body */ switch(tn->type) { case GETS: /* AIS: variableconstants means GETS has been generalised */ if(variableconstants) { revprexpr(tn->u.node->lval, fp, tn->u.node->rval); nodefree(tn->u.node); break; } /* Start of AIS optimization */ np = tn->u.node; if(np->lval->opcode == SUB) np = np->lval; if(flowoptimize && ick_Base == 2 && !opoverused && !variableconstants && (np->lval->opcode == ick_TWOSPOT || np->lval->opcode == ick_HYBRID || !(tn->u.node->rval->optdata & ~0xffffLU))) { atom* op; int ignorable = 1; assert(oblist != NULL); for(op = oblist; op < obdex; op++) { if(op->type == np->lval->opcode && (unsigned long)op->intindex == np->lval->constant) { ignorable &= op->ignorable; } } if(!ignorable) { /* Variable can't be ignored, and expression must be in range */ (void) fprintf(fp,"\t"""); prexpr(tn->u.node->lval, fp, 1); (void) fprintf(fp, " = "); prexpr(tn->u.node->rval, fp, 1); (void) fprintf(fp, ";\n"); break; } } /* End of AIS optimization */ if(opoverused&& (tn->u.node->lval->opcode==ick_ONESPOT|| tn->u.node->lval->opcode==ick_TWOSPOT)) /* AIS */ { (void) fprintf(fp,"\t"""); ooprvar(tn->u.node->lval, fp, 1); (void) fprintf(fp,".set("); prexpr(tn->u.node->rval, fp, 1); (void) fprintf(fp,",os%dspot%lu);\n", ((tn->u.node->lval->opcode==ick_TWOSPOT)?1:0)+1, tn->u.node->lval->constant); } else if(!pickcompile) { np = tn->u.node; if (np->lval->opcode != SUB) { sp = np->lval; (void) fprintf(fp,"\t""(void) ick_assign((char*)&"); } else { sp = np->lval->lval; (void) fprintf(fp,"\t""(void) ick_assign("); } prvar(np->lval, fp, 1); (void) fprintf(fp,", %s", nameof(sp->opcode, vartypes)); (void) fprintf(fp,", %s[%lu], ", nameof(sp->opcode, forgetbits), sp->constant); prexpr(np->rval, fp, 1); (void) fprintf(fp,");\n"); } else /* AIS: Added this case for the simpler PIC assignment rules */ { (void) fprintf(fp,"\t""if(ignore%s%lu) ", nameof(tn->u.node->lval->opcode,varstores), tn->u.node->lval->constant); prexpr(tn->u.node->lval, fp, 1); (void) fprintf(fp, " = "); prexpr(tn->u.node->rval, fp, 1); (void) fprintf(fp, ";\n"); } break; case RESIZE: if(pickcompile) ick_lose(IE256, emitlineno, (const char*) NULL); /* AIS */ np = tn->u.node; dim = 0; for (sp = np->rval; sp; sp = sp->rval) dim++; (void) fprintf(fp, "\t""ick_resize("); prvar(np->lval, fp, 1); #ifdef BOOL_VARARGS_BROKEN (void) fprintf(fp, ", (int)%s[%lu]", nameof(np->lval->opcode, forgetbits), np->lval->constant); #else (void) fprintf(fp, ", %s[%lu]", nameof(np->lval->opcode, forgetbits), np->lval->constant); #endif (void) fprintf(fp, ", %d", dim); for (sp = np->rval; sp; sp = sp->rval) { (void) fprintf(fp, ", (size_t)"); prexpr(sp->lval, fp, 1); } (void) fprintf(fp, ");\n"); break; case NEXT: /* AIS: if using ickec, use its features for the next */ if(useickec) { (void) fprintf(fp,"\t""ick_dogoto(%uU,ick_lineno,1);\n",tn->u.target); break; } /* Start of AIS optimization */ if(tn->u.target>=1000 && tn->u.target<=1999 && pickcompile) { /* optimize syslib call on a PIC */ (void) fprintf(fp, "\t""syslibopt%u();\n", tn->u.target); break; } if(tn->optversion) { /* optimizef has checked that this is a valid optimization */ (void) fprintf(fp, "\t""if(1 == "); prexpr(tn->u.node, fp, 1); /* frees optimizef's nodecopy */ /* AIS: Everything now in one giant switch(), with some very strange constructs (including ;{;} as a null statement; this makes degenerating the code slightly easier) */ (void) fprintf(fp, ") {ick_pushnext(%d); ick_skipto=%uU; goto top;}} case %d:;{;\n", (int)(tn - tuples + 1), tn->nexttarget, (int)(tn - tuples + 1)); break; } /* End of AIS optimization */ (void) fprintf(fp, /* same change as above (case rather than a label) */ "\t""ick_pushnext(%d); goto L%u;} case %d:;{;\n", (int)(tn - tuples + 1), tn->u.target, (int)(tn - tuples + 1)); break; case GO_BACK: /* By AIS */ if(!multithread) ick_lose(IE405, emitlineno, (const char*) NULL); (void) fprintf(fp, "\t""choiceback();\n"); break; case GO_AHEAD: /* By AIS */ if(!multithread) ick_lose(IE405, emitlineno, (const char*) NULL); (void) fprintf(fp, "\t""choiceahead();\n"); break; case RESUME: if(useickec) /* AIS */ { (void) fprintf(fp, "\t""ick_doresume("); prexpr(tn->u.node, fp, 1); (void) fprintf(fp, ", ick_lineno);\n"); break; } (void) fprintf(fp, "\t""ick_skipto = ick_resume("); prexpr(tn->u.node, fp, 1); (void) fprintf(fp, "); goto top;\n"); break; case FORGET: if(useickec) /* AIS */ { (void) fprintf(fp, "\t""ick_forget("); prexpr(tn->u.node, fp, 1); (void) fprintf(fp, ");\n"); break; } (void) fprintf(fp, "\t""ick_popnext("); prexpr(tn->u.node, fp, 1); (void) fprintf(fp, ");\n"); break; case STASH: for (np = tn->u.node; np; np = np->rval) (void) fprintf(fp, "\t""ICKSTASH(%s, %lu, %s, %s%s);\n", nameof(np->opcode, vartypes), np->constant, nameof(np->opcode, varstores), /* AIS */(opoverused&&(np->opcode==ick_ONESPOT|| np->opcode==ick_TWOSPOT)? "ick_oo_":"0"), /* AIS */(opoverused&&(np->opcode==ick_ONESPOT|| np->opcode==ick_TWOSPOT)? nameof(np->opcode, varstoresdem):"0")); break; case RETRIEVE: for (np = tn->u.node; np; np = np->rval) (void) fprintf(fp, "\t""ICKRETRIEVE(%s, %lu, %s, %s, %s%s);\n", nameof(np->opcode, varstores), np->constant, nameof(np->opcode, vartypes), nameof(np->opcode, forgetbits), /* AIS */(opoverused&&(np->opcode==ick_ONESPOT|| np->opcode==ick_TWOSPOT)? "ick_oo_":"0"), /* AIS */(opoverused&&(np->opcode==ick_ONESPOT|| np->opcode==ick_TWOSPOT)? nameof(np->opcode, varstoresdem):"0")); break; case IGNORE: for (np = tn->u.node; np; np = np->rval) (void) fprintf(fp,"\t""ICKIGNORE(%s,%lu,%s) = true;\n", nameof(np->opcode, forgetbits), np->constant, nameof(np->opcode, varstores)); break; case REMEMBER: for (np = tn->u.node; np; np = np->rval) (void) fprintf(fp,"\t""ICKIGNORE(%s,%lu,%s) = false;\n", nameof(np->opcode, forgetbits), np->constant, nameof(np->opcode, varstores)); break; /* All abstention code has been edited by AIS to allow for the new abstention rules */ case ABSTAIN: /* AIS: In CLC-INTERCAL, you can't abstain a GIVE UP line, so I copied a modified version of Joris's REINSTATE patch here as well */ if (!ick_clcsemantics || (tuples + tn->u.target - 1)->type != GIVE_UP) { if(!pickcompile) (void) fprintf(fp, "\t""if(!ICKABSTAINED(%u)) ICKABSTAINED(%u) = 1;\n", tn->u.target - 1, tn->u.target-1); else (void) fprintf(fp, "ICKABSTAINED(%u) = 1;\n", tn->u.target-1); } else (void) fprintf(fp, "\t""/* not abstaining from a GIVE UP line */\n");; break; case FROM: if(pickcompile) ick_lose(IE256, emitlineno, (const char*) NULL); (void) fprintf(fp, "\t""ICKABSTAINED(%u)+=", tn->u.target-1); tn->u.node->width = 32; prexpr(tn->u.node,fp, 1); (void) fprintf(fp, ";\n"); break; case REINSTATE: /* (Joris Huizer) ensure it is not a GIVE UP statement */ if ((tuples + tn->u.target - 1)->type != GIVE_UP) { if(!pickcompile) (void) fprintf(fp, "\t""if(ICKABSTAINED(%u)) ICKABSTAINED(%u)--;\n", tn->u.target - 1, tn->u.target-1); else (void) fprintf(fp, "\t""ICKABSTAINED(%u)=0;\n", tn->u.target - 1); } else (void) fprintf(fp, "\t""/* not reinstating a GIVE UP line */\n"); break; case ENABLE: case DISABLE: case MANYFROM: /* AIS: This code has been rewritten to make use of the revlinetype array (an optimisation that Joris Huizer came up with; however, I am not using his code, but rewriting it, to make use of a single array and an index to it, rather than one array for each command type, for maintainability reasons. */ if(pickcompile) ick_lose(IE256, emitlineno, (const char*) NULL); (void) fprintf(fp,"\tint i;\n"); np=tn->u.node; if(tn->type==MANYFROM) { np=np->rval; fprintf(fp,"\tint j = "); prexpr(tn->u.node->lval, fp, 1); fprintf(fp,";\n"); } for(; np; np = np->rval) { int npc = np->constant; anothertype: (void) fprintf(fp,"\n\tfor(i=revlineindex[%s];itype) { case ENABLE: (void) fprintf(fp,"\t if (ick_abstained[revlinetype[i]])" "\t\tick_abstained[revlinetype[i]]--;\n"); break; case DISABLE: (void) fprintf(fp,"\t if(!ick_abstained[revlinetype[i]])" "\t\tick_abstained[revlinetype[i]]=1;\n"); break; case MANYFROM:(void) fprintf(fp,"\tick_abstained[revlinetype[i]]+=j;\n"); break; default: ick_lose(IE994, emitlineno, (const char *)NULL); } switch(npc) { case GETS: npc=RESIZE; goto anothertype; case ABSTAIN: npc=DISABLE; goto anothertype; case DISABLE: npc=FROM; goto anothertype; case FROM: npc=MANYFROM; goto anothertype; case REINSTATE: npc=ENABLE; goto anothertype; case COME_FROM: npc=COMPUCOME; goto anothertype; case COMPUCOME: npc=GERUCOME; goto anothertype; case NEXTFROMLABEL: npc=NEXTFROMEXPR; goto anothertype; case NEXTFROMEXPR: npc=NEXTFROMGERUND; goto anothertype; default: break; } } break; case NEXTFROMEXPR: case NEXTFROMGERUND: case GERUCOME: case COMPUCOME: /* By AIS. Note that this doesn't even have balanced braces; it's designed to work with COMPUCOME's crazy guarding arrangements */ if(pickcompile) ick_lose(IE256, emitlineno, (const char*) NULL); /* AIS */ if(useickec) /* use ick_ec's features for next from and come from*/ { if(tn->type == COMPUCOME) { fprintf(fp,"\t""ick_docomefromif("); prexpr(tn->u.node, fp, 1); fprintf(fp,",ick_lineno,({int i=0;"); emit_guard(tn,fp); /* re-emit the guard */ fprintf(fp,"i=1;};i;}));\n"); break; } else if(tn->type == NEXTFROMEXPR) { fprintf(fp,"\t""ick_donextfromif("); prexpr(tn->u.node, fp, 1); fprintf(fp,",ick_lineno,({int i=0;"); emit_guard(tn,fp); /* re-emit the guard */ fprintf(fp,"i=1;};i;}));\n"); break; } } fprintf(fp,"\t""%s;} else goto CCF%d;\n", multithread?"NEXTTHREAD":useprintflow? "if(ick_printflow) fprintf(stderr,\"[%d]\",ick_lineno)":"", compucomecount); break; case GIVE_UP: /* AIS: Edited to allow for yuk */ if(yukprofile||yukdebug) fprintf(fp, "\t""YUKTERM;\n"); if(multithread) fprintf(fp, "\t""killthread();\n"); else { if(nonespots||opoverused) fprintf(fp,"\t""if(ick_onespots) free(ick_onespots);\n"); if(ntwospots||opoverused) fprintf(fp,"\t""if(ick_twospots) free(ick_twospots);\n"); if(ntails) fprintf(fp,"\t""if(ick_tails) free(ick_tails);\n"); if(nhybrids) fprintf(fp,"\t""if(ick_hybrids) free(ick_hybrids);\n"); if(nonespots||opoverused) fprintf(fp,"\t""if(ick_oneforget) free(ick_oneforget);\n"); if(ntwospots||opoverused) fprintf(fp,"\t""if(ick_twoforget) free(ick_twoforget);\n"); if(ntails) fprintf(fp,"\t""if(ick_tailforget) free(ick_tailforget);\n"); if(nhybrids) fprintf(fp,"\t""if(ick_hyforget) free(ick_hyforget);\n"); if(opoverused) { fprintf(fp,"\t""if(ick_oo_onespots) free(ick_oo_onespots);\n"); fprintf(fp,"\t""if(ick_oo_twospots) free(ick_oo_twospots);\n"); } fprintf(fp,"\t""if(ick_next) free(ick_next);\n"); if(useickec) fprintf(fp,"\t""if(ick_next_jmpbufs) free(ick_next_jmpbufs);\n"); } (void) fprintf(fp, "\t""exit(0);\n"); break; case TRY_AGAIN: /* By AIS */ (void) fprintf(fp, "\t""goto ick_restart;\n }\n"); if(yukprofile||yukdebug) fprintf(fp, " if(yukloop) goto ick_restart;\n"); if(yukprofile||yukdebug) fprintf(fp, " YUKTERM;\n"); if(multithread) fprintf(fp, "\t""killthread();\n"); else { if(nonespots||opoverused) fprintf(fp,"\t""if(ick_onespots) free(ick_onespots);\n"); if(ntwospots||opoverused) fprintf(fp,"\t""if(ick_twospots) free(ick_twospots);\n"); if(ntails) fprintf(fp,"\t""if(ick_tails) free(ick_tails);\n"); if(nhybrids) fprintf(fp,"\t""if(ick_hybrids) free(ick_hybrids);\n"); if(nonespots||opoverused) fprintf(fp,"\t""if(ick_oneforget) free(ick_oneforget);\n"); if(ntwospots||opoverused) fprintf(fp,"\t""if(ick_twoforget) free(ick_twoforget);\n"); if(ntails) fprintf(fp,"\t""if(ick_tailforget) free(ick_tailforget);\n"); if(nhybrids) fprintf(fp,"\t""if(ick_hyforget) free(ick_hyforget);\n"); if(opoverused) { fprintf(fp,"\t""if(ick_oo_onespots) free(ick_oo_onespots);\n"); fprintf(fp,"\t""if(ick_oo_twospots) free(ick_oo_twospots);\n"); } } (void) fprintf(fp, " {\n\treturn(0);\n"); /* because if TRY AGAIN is the last line, falling off the end isn't an error */ pasttryagain=1; /* flag an error if we try any more commands */ break; case WRITE_IN: if(pickcompile) ick_lose(IE256, emitlineno, (const char*) NULL); /* AIS */ for (np = tn->u.node; np; np = np->rval) { if (np->lval->opcode == ick_TAIL || np->lval->opcode == ick_HYBRID) { (void) fprintf(fp,"\t""ick_binin("); prvar(np->lval, fp, 1); (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) ick_assign((char*)&"); } else { sp = np->lval->lval; (void) fprintf(fp,"\t""(void) ick_assign("); } prvar(np->lval, fp, 1); (void) fprintf(fp,", %s", nameof(sp->opcode, vartypes)); (void) fprintf(fp,", %s[%lu]", nameof(sp->opcode, forgetbits), sp->constant); (void) fprintf(fp,", ick_pin());\n"); } } break; case READ_OUT: if(pickcompile) ick_lose(IE256, emitlineno, (const char*) NULL); /* AIS */ for (np = tn->u.node; np; np = np->rval) { if (np->lval->opcode == ick_TAIL || np->lval->opcode == ick_HYBRID) { (void) fprintf(fp,"\t""ick_binout("); prvar(np->lval, fp, 1); (void) fprintf(fp,");\n"); } else { (void) fprintf(fp, "\t""ick_pout("); prexpr(np->lval, fp, 1); (void) fprintf(fp, ");\n"); } } break; case PIN: /* AIS, with some code borrowed from the GETS code */ np = tn->u.node; (void) fprintf(fp, "\t""TRISA = seq(~(("); prexpr(np, fp, 0); (void) fprintf(fp, " >> 16) & 255));\n"); (void) fprintf(fp, "\t""TRISB = seq(~("); prexpr(np, fp, 0); (void) fprintf(fp, " >> 24));\n"); (void) fprintf(fp, "\t""PORTA = seq(~("); prexpr(np, fp, 0); (void) fprintf(fp, " & 255));\n"); (void) fprintf(fp, "\t""PORTB = seq(~(("); prexpr(np, fp, 0); (void) fprintf(fp, " >> 8) & 255));\n"); { atom* op; int ignorable = 1; assert(oblist != NULL); for(op = oblist; op < obdex; op++) { if(op->type == np->opcode && (unsigned long)op->intindex == np->constant) { ignorable &= op->ignorable; } } if(!ignorable) { /* Variable can't be ignored, and expression must be in range */ (void) fprintf(fp,"\t"""); prexpr(np, fp, 1); (void) fprintf(fp, " = "); } else { np = tn->u.node; (void) fprintf(fp,"\t""if(ignore%s%lu) ", nameof(np->opcode,varstores), np->constant); prexpr(np, fp, 1); (void) fprintf(fp, " = "); } } (void) fprintf(fp,"(TRISB<<24) | (TRISA<<16) | (PORTB<<8) | PORTA;\n"); break; case CREATE: /* By AIS */ if(createsused == 0) goto splatme; (void) fprintf(fp,"\t""ick_registercreation(\""); (void) prunknownstr(tn->u.node, fp); (void) fprintf(fp,"\",%uU);\n",tn->u.target); break; case COMPUCREATE: /* By AIS */ if(createsused == 0) goto splatme; (void) fprintf(fp,"\t""ick_registercreation(\""); (void) prunknownstr(tn->u.node->rval, fp); (void) fprintf(fp,"\","); prexpr(tn->u.node->lval, fp, 1); (void) fprintf(fp,");\n"); free(tn->u.node); /* don't free the rval */ break; case UNKNOWN: /* By AIS */ /* We generate a check to see if the unknown statement has gained a meaning since it was compiled, or otherwise continue to the splattered case. Not for PIC-INTERCAL, though. */ if(!pickcompile) prunknown(tn->u.node, fp); /*@fallthrough@*/ case SPLATTERED: /* AIS: The code previously here could access unallocated memory due to a bug if the comment was a COME FROM target. The problem is that emitlineno (the line to show an error on) is usually the line after this one, but not always, and in this case the line after this one is always what we want, so I copied the relevant part of the emitlineno logic here to fix the bug. */ splatme: if (tn < tuples + ick_lineno - 1) dim = tn[1].ick_lineno - tn->ick_lineno; else dim = iyylineno - tn->ick_lineno; if (tn->sharedline) ++dim; (void) fprintf(fp, "\t""ick_lose(IE000, %d, \"%s\");\n", emitlineno, nice_text(textlines + tn->ick_lineno, dim)); break; case PREPROC: /* AIS: 'DO NOTHING', but not enterable into a program. This is generated by the preprocessor. */ fprintf(fp,"\t""; /* do nothing */\n"); break; case COME_FROM: case NEXTFROMLABEL: /* AIS */ if(useickec) /* AIS */ { if(tn->type == COME_FROM) { fprintf(fp,"\t""ick_docomefromif(%uU,ick_lineno,({int i=0;", tn->u.target); emit_guard(tn,fp); /* re-emit the guard */ fprintf(fp,"i=1;};i;}));\n"); break; } else /* (tn->type == NEXTFROMLABEL) */ { fprintf(fp,"\t""ick_donextfromif(%uU,ick_lineno,({int i=0;", tn->u.target); emit_guard(tn,fp); /* re-emit the guard */ fprintf(fp,"i=1;};i;}));\n"); break; } } (void) fprintf(fp, "if(0) {C%ld: %s;%s}\n", (long)(tn-tuples+1), tn->type==NEXTFROMLABEL ? "ick_pushnext(truelineno+1)":"", multithread?" NEXTTHREAD;":!useprintflow?"" :" if(ick_printflow) " "fprintf(stderr,\"[%d]\",ick_lineno);"); /* AIS: Changed so all COME_FROMs have unique labels even if two of them aim at the same line, and added the NEXT FROM case (which involves hiding COME FROM labels in an unreachable if()). */ break; case WHILE: /* AIS: fall through to the error, because this shouldn't come up yet. */ default: ick_lose(IE994, emitlineno, (const char *)NULL); /*@-unreachable@*/ break; /*@=unreachable@*/ } if ((tn->type != COME_FROM && tn->type != NEXTFROMLABEL) || /*AIS*/ useickec) (void) fprintf(fp, " }\n"); skipcomment: if ((!useickec && (tn->type == COMPUCOME || tn->type == NEXTFROMEXPR)) || tn->type == NEXTFROMGERUND || tn->type == GERUCOME ) { /* By AIS */ (void) fprintf(fp," else goto CCF%d;\n",compucomecount); (void) fprintf(fp," ick_ccfc++;\n"); /* Note that due to the semantics of setjmp, this has to be written as 2 separate ifs. The MULTICOME macro expands to a non-multithreaded or multithreaded function for handling a COME FROM clash. */ (void) fprintf(fp," if(ick_ccfc==1||MULTICOME(%d,ick_cjb))\n" "\t""if(setjmp(ick_cjb) == 0) goto CCF%d;\n", emitlineno, compucomecount); /* Of course, emitlineno is unlikely to be helpful! */ if(tn->type == NEXTFROMEXPR || tn->type == NEXTFROMGERUND) { /* Stack up the statement we've NEXTed from */ (void) fprintf(fp," ick_pushnext(truelineno+1);\n"); } (void) fprintf(fp," }\n"); } /* AIS: Before any COMING FROM this line is done, we need to sort out ONCE and AGAIN situations, unless this line was a NEXT or GO_BACK. COME FROM is also excluded because it acts at the suckpoint, not at the place it's written in the program. */ if (tn->onceagainflag != onceagain_NORMAL && tn->type != NEXT && tn->type != GO_BACK && tn->type != UNKNOWN && ((tn->type != COME_FROM && tn->type != NEXTFROMLABEL) || useickec)) { /* See my comments against the NEXT code for more information. This code is placed here so COME FROM ... ONCE constructs work properly (the line is ick_abstained if the COME FROM is reached in execution, or its suckpoint is reached in execution). */ fprintf(fp," ick_oldabstain = ICKABSTAINED(%d);\n", (int)(tn - tuples)); fprintf(fp," ICKABSTAINED(%d) = %s;\n", (int)(tn - tuples), tn->onceagainflag==onceagain_ONCE ? "ick_oldabstain ? ick_oldabstain : 1" : "0"); } /* AIS: This is where we start the COME FROM suckpoint code. */ /* AIS: The ickec version is very simple! We just finish the labeled block started at the start of the command. */ if(tn->label && useickec) (void) fprintf(fp, "});\n"); /* AIS: We need to keep track of how many COME FROMs are aiming here at runtime, if we don't have the very simple situation of no COMPUCOMEs and a single-thread program (in which case the check is done at compile-time by codecheck). Even without COMPUCOME, this can change in a multithread program due to abstentions. */ if((tn->ncomefrom && multithread) || (tn->label && compucomesused) || gerucomesused) (void) fprintf(fp, " ick_ccfc = 0;\n"); /* AIS: For NEXTING FROM this line */ if(nextfromsused && tn->ncomefrom) { (void) fprintf(fp, " truelineno = %d;\n", (int)(tn-tuples)); } /* * If the statement that was just degenerated was a COME FROM target, * emit the code for the jump to the COME FROM. * AIS: Changed most of this to allow for multithreading. */ while(tn->ncomefrom && !useickec) /* acts as an if if singlethreading */ { tuple* cf; /* local to this block */ if(multithread || compucomesused) generatecfjump = 1; cf = tuples+comefromsearch(tn,tn->ncomefrom)-1; if (yydebug || compile_only) (void) fprintf(fp, " /* line %03d is a suck point for the COME FROM " "at line %03d */\n", tn->ick_lineno, cf->ick_lineno); if (cf->onceagainflag != onceagain_NORMAL) { /* Calculate ONCE/AGAIN when the suckpoint is passed */ fprintf(fp," ick_oldabstain = ICKABSTAINED(%d);\n", (int)(cf - tuples)); fprintf(fp," ICKABSTAINED(%d) = %s;\n", (int)(cf - tuples), cf->onceagainflag==onceagain_ONCE ? "ick_oldabstain ? ick_oldabstain : 1" : "0"); } emit_guard(cf, fp); if(multithread || compucomesused) (void) fprintf(fp, "\t""ick_ccfc++;\tif(ick_ccfc==1||MULTICOME(%d,ick_cjb)) " "if(setjmp(ick_cjb) == 1) goto C%ld;\n }\n", emitlineno, (long)(cf-tuples+1)); else /* optimize for the simple case */ (void) fprintf(fp, "\t""goto C%ld;\n }\n", (long)(cf-tuples+1)); tn->ncomefrom--; } /* AIS: If the statement has a label, it might be a computed COME FROM target. Also check the flag that says this code is needed in a multithread non-COMPUCOME program. If (at runtime) ick_ccfc is nonzero, we know ick_cjb has already been set; otherwise, set it now. In the case of a multithread non-COMPUCOME program, the goto will just jump to a longjmp, switching to the one and only one COME FROM that hasn't been given its own thread. However, skip all the compucomes and gerucomes if preproc is set, because COMING FROM a preproc should only ever be done by label. */ if (((tn->label && compucomesused) || generatecfjump || gerucomesused) && (!tn->preproc || generatecfjump) && (!useickec || gerucomesused)) { if(compucomesused) { (void) fprintf(fp, " ick_skipto = %u;\n", tn->label); } if(gerucomesused || nextfromsused) { (void) fprintf(fp, " truelineno = %d;\n", (int)(tn-tuples)); } if(generatecfjump) (void) fprintf(fp, " if(ick_ccfc) goto CCF%s;\n", tn->preproc?"L":"0"); if((compucomesused || gerucomesused) && !tn->preproc) { /* check all the COMPUCOMES */ (void) fprintf(fp, " %sif(setjmp(ick_cjb) == 0) goto CCF0;\n", generatecfjump?"else ":""); } generatecfjump = 0; /* AIS: If NEXT FROM's used, this might be a NEXT return target. Don't generate case labels for NEXT, as it has them already. */ if(nextfromsused && tn->type != NEXT) { (void) fprintf(fp, " case %u:;\n", (unsigned)(tn-tuples+1)); } } /* AIS: Now we've finished the statement, let's switch to the next thread in a multithread program. */ if(multithread) (void) fputs(" NEXTTHREAD;\n", fp); else if(useprintflow) (void) fputs(" if(ick_printflow) fprintf(stderr," "\"[%d]\",ick_lineno);\n",fp); } /*@=nestedextern@*/ /* AIS: Generate prototypes for slat expressions, args to UNKNOWN */ void emitslatproto(FILE* fp) { node* np=firstslat; const char* t="ick_type32"; while(np) { fprintf(fp,"%s ick_og%lx(%s);\nvoid ick_os%lx(%s, void(*)());\n", t,(unsigned long)np,t,(unsigned long)np,t); np=np->nextslat; } } /* AIS: Generate bodies for slat expressions, args to UNKNOWN */ void emitslat(FILE* fp) { node* np=firstslat; node* temp, *temp2; const char* t="ick_type32"; while(np) { fprintf(fp, "void ick_os%lx(%s a, void(*f)())\n{\n static int l=0;\n" " if(l)\n {\n if(!f) ick_lose(IE994, ick_lineno, (const char *)NULL);\n" " f(a,0);\n return;\n }\n l=1;\n", (unsigned long)np,t); temp=cons(C_A, 0, 0); revprexpr(np, fp, temp); /* revprexpr can't free */ fprintf(fp," l=0;\n}\n"); fprintf(fp,"%s ick_og%lx(%s t)\n{\n %s a;\n static int l=0;\n" " if(l) return t;\n l=1;\n a=", t,(unsigned long)np,t,t); prexpr(np, fp, 0); fprintf(fp,";\n l=0;\n return a;\n}\n"); np=np->nextslat; } np=firstslat; /* Note that the order in which the parser assembles nodes means that we have to free the nodes in reverse order so we don't free child nodes twice. */ temp2=0; while(np) { temp=np->nextslat; np->nextslat=temp2; /* reverse the chain */ temp2=np; np=temp; } np=temp2; while(np) { temp=np->nextslat; nodefree(np); np=temp; } /* JH: clear firstslat */ firstslat = 0; } /* feh.c ends here */ intercal-0.29/src/oil.y0000644000175000017500000006167411443404360014702 0ustar brooniebroonie/***************************************************************************** NAME oil.y -- compiler for Optimizer Idiom Language files LICENSE TERMS Copyright (C) 2007 Alex Smith 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 "config.h" #include #include #include #include #include "ick_bool.h" /* Define strdup if it isn't available */ #ifndef HAVE_STRDUP char* strdup(const char* s) { char* t=malloc(strlen(s)+1); if(t) strcpy(t,s); return t; } #endif /* #define YYDEBUG 1 int yydebug=1; */ /* Each semantic value represents either a constraint on a node that needs to be true for the optimization template to match, or part of the replacement for the optimization template. */ struct ickstype { unsigned depth; /* The number of child nodes this is from the root */ unsigned long path; /* Bits from the end of this number represent the sequence of lvals (=0) or rvals (=1) this is from the root; depth bits from the end are relevant, and the bit nearest the root is least significant */ const char* condition; /* Points to a constant string; the condition to generate on that node. Could also point to something the lexer mallocs, but then the lexer has to keep track of being able to free it again. If this is NULL, it means that there isn't a condition other than maybe mustbemesh */ const char* nodetypename; /* The name of the type of node this condition matches, or NULL for a LEXERLEAF */ bool usec; /* Whether to append the value of c to the condition */ bool mustbemesh; /* Must this node be a mesh or mesh32? */ bool cxneeded; /* True means calculate c and x for the node and the condition is on those; false means append 'condition' to the node itself to form the condition and c and x aren't needed */ bool width32; /* Generate a 32-bit node? */ bool ublo; /* Is this a UBLO (if set, generate conditions to check width)? */ unsigned long c; /* The value to append to the condition */ int replnum; /* Number of this group for replacements */ struct ickstype *n1;/* n1 and n2 are pointers to other conditions that */ struct ickstype *n2;/* also have to be satisified */ }; #define YYSTYPE YYSTYPE #define MAXOPTNAMELEN 64 char optname[MAXOPTNAMELEN]="undefined"; int optnumber = 0; typedef struct ickstype *YYSTYPE; void splitend(void); void splitstart(void); void treedepthup(YYSTYPE, bool); void treefree(YYSTYPE); void gennodepath(unsigned, unsigned long); bool treeshapecond(YYSTYPE, bool); YYSTYPE treenscheck(YYSTYPE, YYSTYPE, int); void treecxcond(YYSTYPE); void treerepcount(YYSTYPE, int*); void treerepgen(YYSTYPE, YYSTYPE*, int*); int countgetchar(void); int countungetc(int, FILE*); int cgccol; int cgcrow; /* #defines for chaining together template expressions; here, s is the type of expression (e.g. select, bitwise and, unary and) that's chaining the expressions together and n is the nonterminal that's the rval */ #define BINARYEXPR(s,m,l,r,w) do{ \ m=malloc(sizeof(struct ickstype)); \ m->n1=l; \ m->n2=r; \ m->usec=0; \ m->condition="->opcode==" s; \ m->nodetypename=s; \ m->mustbemesh=0; \ m->cxneeded=0; \ m->depth=0; \ m->path=0; \ m->replnum=0; \ m->width32=w; \ m->ublo=0; \ treedepthup(m->n1,0); \ treedepthup(m->n2,1); \ } while(0) #define UNARYEXPR(s,m,r,w,u) do{ \ m=malloc(sizeof(struct ickstype)); \ m->n1=0; \ m->n2=r; \ m->usec=0; \ m->condition="->opcode==" s; \ m->nodetypename=s; \ m->mustbemesh=0; \ m->cxneeded=0; \ m->depth=0; \ m->path=0; \ m->replnum=0; \ m->width32=w; \ m->ublo=u; \ treedepthup(m->n2,1); \ } while(0) /* Error handling and lexing */ int yylex(void); int yyerror(char const *); /* Split the output file */ #define SPLITMAX 20 int splitcount=SPLITMAX; int filenumber=0; bool inloop=0; %} /* Various conditions can come out from the lexer. The most common is a char, which represents that C or INTERCAL operation in a template. Non-character tokens are used for the various possible leaves in a template, though: .1 A 16-bit expression (number 1, for replacements) :1 A 32-bit expression (number 1, for replacements) _1 An expression of any width (again, number 1 for replacements) #1 A constant with the value 1 #{x==1}3 A constant which equals 1 (number 3, for replacements) Note that in the last example, the expression is written strictly in C; for instance, #{ick_iselect(x,x)==1}4 would select a constant that's a power of 2 (ick_iselect is the C name for the INTERCAL operation 'select'). .{c&0xfffffffe==0}5 A 16-bit expression (number 5, for replacements) which has been analysed to not possibly have any bits other than the least significant set (c is here the list of all potentially set bits) All of these come out as correctly set LEXERLEAFs. Expressions with identical numbers must be node-for-node identical, except for number 0 (which is like _ in Prolog, it means 'can be anything and disregard the value). This holds true even if they have different sigils. Expressions can use each other's c and x values with the notation c5, x4, and so on; replacement numbers are limited to 1 digit. The other things that can come out from the lexer are sparks, ears, and parentheses (any mix, we're not fussy). */ %token LEXERLEAF %% input: /**/ | input optimization ; optimization: template '-' '>' replacement { static YYSTYPE tempmem[10]; static int replcount[10]; /* Handle splitting the file. */ if(splitcount) splitcount--; if(!splitcount && !inloop) { splitcount=SPLITMAX; splitend(); ++filenumber; splitstart(); } /* This is where we actually generate the optimizer code. */ /* Tree-shape and is-constant conditions */ printf(" checknodeactbits(np);\n"); if(treeshapecond($1,1)) printf(" if(1"); printf(")\n do\n {\n"); /* Nodesame and cxdata conditions */ { int i=10; YYSTYPE temp; while(--i) { temp=treenscheck($1,0,i); if(temp) { printf(" x%d=np",i); gennodepath(temp->depth,temp->path); printf("->constant; c%d=np",i); gennodepath(temp->depth,temp->path); printf("->optdata;\n"); } tempmem[i]=temp; replcount[i]=0; /* we need to zero this somewhere, may as well be here */ } treecxcond($1); } /* If we reach this point in the generated code, we have an optimizer template match. */ printf(" OPTING(%s_%d);\n",optname,++optnumber); /* We now need to replace np with its replacement. This is done by creating a new nodetree, copying across tempmem'd nodes where necessary, and then substituting one for the other. (This is an inefficient but general way to do this.) One special case is needed; because pointers into the root node need to continue pointing there, the temporary node tp is copied member-for-member and then freed again. The root width can change (this is a deviation from previous code), in order to prevent a bug where the new root happens to be a unary. (This means we can get a 16-bit unary applied to 32-bit data; but the optimiser is meant to ensure that this is not problematic.) */ printf(" tp=newnode();\n"); treerepcount($4,replcount); treerepgen($4,tempmem,replcount); printf(" nodefree(np->lval); nodefree(np->rval);\n"); printf(" *np=*tp; free(tp);\n"); printf(" } while(0);\n\n"); /* Free the template and replacement now they're finished being used. */ treefree($1); treefree($4); } | '<' LEXERLEAF '-' LEXERLEAF { if(!$2->mustbemesh||!$4->mustbemesh) { yyerror("syntax error in <#..#()->()> construct"); free($2); free($4); YYERROR; } printf(" r=%luLU; while(r<=%luLU) {\n",$2->c,$4->c); free($2); free($4); inloop=1; } | '>' {printf(" r++;\n }\n"); inloop=0;}; template: expr3 ; expr3: '(' expr2 ')' {$$=$2;} | '"' expr2 '"' {$$=$2;} | '\'' expr2 '\'' {$$=$2;} expr: expr3 | LEXERLEAF ; expr2: expr '$' expr {BINARYEXPR("MINGLE",$$,$1,$3,1);} | expr '~' expr {BINARYEXPR("SELECT",$$,$1,$3,1);} | expr '~' '1' '6' expr {BINARYEXPR("SELECT",$$,$1,$5,0);} | expr '~' '3' '2' expr {BINARYEXPR("SELECT",$$,$1,$5,1);} | '&' '1' '6' expr {UNARYEXPR("AND",$$,$4,0,1);} | '&' '3' '2' expr {UNARYEXPR("AND",$$,$4,1,1);} | 'V' '1' '6' expr {UNARYEXPR("OR",$$,$4,0,1);} | 'V' '3' '2' expr {UNARYEXPR("OR",$$,$4,1,1);} | '?' '1' '6' expr {UNARYEXPR("XOR",$$,$4,0,1);} | '?' '3' '2' expr {UNARYEXPR("XOR",$$,$4,1,1);} | '^' '1' '6' expr {UNARYEXPR("FIN",$$,$4,0,1);} | '^' '3' '2' expr {UNARYEXPR("FIN",$$,$4,1,1);} | '@' '1' '6' expr {UNARYEXPR("WHIRL",$$,$4,0,1);} | '@' '2' '1' '6' expr {UNARYEXPR("WHIRL2",$$,$5,0,1);} | '@' '3' '1' '6' expr {UNARYEXPR("WHIRL3",$$,$5,0,1);} | '@' '4' '1' '6' expr {UNARYEXPR("WHIRL4",$$,$5,0,1);} | '@' '5' '1' '6' expr {UNARYEXPR("WHIRL5",$$,$5,0,1);} | '@' '3' '2' expr {UNARYEXPR("WHIRL",$$,$4,1,1);} | '@' '2' '3' '2' expr {UNARYEXPR("WHIRL2",$$,$5,1,1);} | '@' '3' '3' '2' expr {UNARYEXPR("WHIRL3",$$,$5,1,1);} | '@' '4' '3' '2' expr {UNARYEXPR("WHIRL4",$$,$5,1,1);} | '@' '5' '3' '2' expr {UNARYEXPR("WHIRL5",$$,$5,1,1);} | expr '&' expr {BINARYEXPR("C_AND",$$,$1,$3,1);} | expr '&' '1' '6' expr {BINARYEXPR("C_AND",$$,$1,$5,0);} | expr '&' '3' '2' expr {BINARYEXPR("C_AND",$$,$1,$5,1);} | expr '|' expr {BINARYEXPR("C_OR",$$,$1,$3,1);} | expr '|' '1' '6' expr {BINARYEXPR("C_OR",$$,$1,$5,0);} | expr '|' '3' '2' expr {BINARYEXPR("C_OR",$$,$1,$5,1);} | expr '^' expr {BINARYEXPR("C_XOR",$$,$1,$3,1);} | expr '^' '1' '6' expr {BINARYEXPR("C_XOR",$$,$1,$5,0);} | expr '^' '3' '2' expr {BINARYEXPR("C_XOR",$$,$1,$5,1);} | expr '+' expr {BINARYEXPR("C_PLUS",$$,$1,$3,1);} | expr '+' '1' '6' expr {BINARYEXPR("C_PLUS",$$,$1,$5,0);} | expr '+' '3' '2' expr {BINARYEXPR("C_PLUS",$$,$1,$5,1);} | expr '-' expr {BINARYEXPR("C_MINUS",$$,$1,$3,1);} | expr '-' '1' '6' expr {BINARYEXPR("C_MINUS",$$,$1,$5,0);} | expr '-' '3' '2' expr {BINARYEXPR("C_MINUS",$$,$1,$5,1);} | expr '*' expr {BINARYEXPR("C_TIMES",$$,$1,$3,1);} | expr '*' '1' '6' expr {BINARYEXPR("C_TIMES",$$,$1,$5,0);} | expr '*' '3' '2' expr {BINARYEXPR("C_TIMES",$$,$1,$5,1);} | expr '/' expr {BINARYEXPR("C_DIVIDEBY",$$,$1,$3,1);} | expr '/' '1' '6' expr {BINARYEXPR("C_DIVIDEBY",$$,$1,$5,0);} | expr '/' '3' '2' expr {BINARYEXPR("C_DIVIDEBY",$$,$1,$5,1);} | expr '%' expr {BINARYEXPR("C_MODULUS",$$,$1,$3,1);} | expr '%' '1' '6' expr {BINARYEXPR("C_MODULUS",$$,$1,$5,0);} | expr '%' '3' '2' expr {BINARYEXPR("C_MODULUS",$$,$1,$5,1);} | expr '>' expr {BINARYEXPR("C_GREATER",$$,$1,$3,1);} | expr '>' '1' '6' expr {BINARYEXPR("C_GREATER",$$,$1,$5,0);} | expr '>' '3' '2' expr {BINARYEXPR("C_GREATER",$$,$1,$5,1);} | expr '<' expr {BINARYEXPR("C_LESS",$$,$1,$3,1);} | expr '<' '1' '6' expr {BINARYEXPR("C_LESS",$$,$1,$5,0);} | expr '<' '3' '2' expr {BINARYEXPR("C_LESS",$$,$1,$5,1);} | '~' '1' '6' expr {UNARYEXPR("C_NOT",$$,$4,0,1);} | '~' '3' '2' expr {UNARYEXPR("C_NOT",$$,$4,1,1);} | expr '!' '=' expr {BINARYEXPR("C_NOTEQUAL",$$,$1,$4,0);} | expr '!' '=' '1' '6' expr {BINARYEXPR("C_NOTEQUAL",$$,$1,$6,0);} | expr '!' '=' '3' '2' expr {BINARYEXPR("C_NOTEQUAL",$$,$1,$6,1);} | expr '=' '=' expr {BINARYEXPR("C_ISEQUAL",$$,$1,$4,0);} | expr '=' '=' '1' '6' expr {BINARYEXPR("C_ISEQUAL",$$,$1,$6,0);} | expr '=' '=' '3' '2' expr {BINARYEXPR("C_ISEQUAL",$$,$1,$6,1);} | expr '&' '&' expr {BINARYEXPR("C_LOGICALAND",$$,$1,$4,0);} | expr '&' '&' '1' '6' expr {BINARYEXPR("C_LOGICALAND",$$,$1,$6,0);} | expr '&' '&' '3' '2' expr {BINARYEXPR("C_LOGICALAND",$$,$1,$6,1);} | expr '|' '|' expr {BINARYEXPR("C_LOGICALOR",$$,$1,$4,0);} | expr '|' '|' '1' '6' expr {BINARYEXPR("C_LOGICALOR",$$,$1,$6,0);} | expr '|' '|' '3' '2' expr {BINARYEXPR("C_LOGICALOR",$$,$1,$6,1);} | expr '>' '>' expr {BINARYEXPR("C_RSHIFTBY",$$,$1,$4,1);} | expr '>' '>' '1' '6' expr {BINARYEXPR("C_RSHIFTBY",$$,$1,$6,0);} | expr '>' '>' '3' '2' expr {BINARYEXPR("C_RSHIFTBY",$$,$1,$6,1);} | expr '<' '<' expr {BINARYEXPR("C_LSHIFTBY",$$,$1,$4,1);} | expr '<' '<' '1' '6' expr {BINARYEXPR("C_LSHIFTBY",$$,$1,$6,0);} | expr '<' '<' '3' '2' expr {BINARYEXPR("C_LSHIFTBY",$$,$1,$6,1);} | '!' expr {UNARYEXPR("C_LOGICALNOT",$$,$2,0,0);} | '!' '1' '6' expr {UNARYEXPR("C_LOGICALNOT",$$,$4,0,0);} | '!' '3' '2' expr {UNARYEXPR("C_LOGICALNOT",$$,$4,1,0);} | expr ; replacement: expr3; %% #define MAXTOFREE 1000 char* tofree[MAXTOFREE]={0}; int tfi=0; int yylex(void) { int c; unsigned long acc; /* Whitespace is completely insignificant here, even inside && and other two-character operators. Just to be different, though, it /is/ significant inside constructs like .1 and #{1}2; in such cases, it isn't allowed. */ c=countgetchar(); while(isspace(c)) c=countgetchar(); while(c==';'||c=='[') { /* Comments go from a semicolon/hybrid to the end of the line. */ if(c==';') { c=countgetchar(); while(c!='\n') c=countgetchar(); while(isspace(c)) c=countgetchar(); } /* Square brackets set the name for optimizations. */ if(c=='[') { int i=0; c=countgetchar(); while(c!=']') { optname[i++]=c; c=countgetchar(); if(i==MAXOPTNAMELEN-1) {i=0; yyerror("optimization name too long");} } optnumber=0; optname[i]=0; c=countgetchar(); while(isspace(c)) c=countgetchar(); } } if(c==EOF) return 0; switch(c) { case '#': c=countgetchar(); if(c!='{') { acc=0; while(isdigit(c)) { acc*=10; acc+=(c-'0'); c=countgetchar(); } yylval=malloc(sizeof(struct ickstype)); yylval->depth=0; yylval->path=0; yylval->condition="->constant=="; yylval->nodetypename=0; yylval->usec=1; yylval->mustbemesh=1; yylval->cxneeded=0; yylval->c=acc; yylval->replnum=0; yylval->n1=0; yylval->n2=0; yylval->ublo=0; yylval->width32=1; /* generate MESH32 not MESH; we can still AND16 it, etc., if necessary */ countungetc(c, stdin); return LEXERLEAF; } countungetc(c, stdin); c='#'; /* fall through */ case '_': case ':': case '.': yylval=malloc(sizeof(struct ickstype)); yylval->depth=0; yylval->path=0; yylval->condition=0; /* _ or # */ yylval->width32=1; /* should never matter, but you never know... */ yylval->ublo=0; if(c==':') yylval->condition="->width==32"; if(c=='.') {yylval->condition="->width==16"; yylval->width32=0;} yylval->nodetypename=0; yylval->usec=0; yylval->mustbemesh=c=='#'; yylval->cxneeded=0; c=countgetchar(); if(c=='{') { /* Create a new node to hold the c/x condition */ yylval->n1=malloc(sizeof(struct ickstype)); yylval->n1->depth=0; yylval->n1->path=0; { static char buf[512]; int bi=0; c=countgetchar(); while(c!='}') { buf[bi++]=c; if(bi==511) {yyerror("{quoted} string too long"); bi=0;} c=countgetchar(); } buf[bi]=0; yylval->n1->condition=tofree[tfi++]=strdup(buf); if(tfi==MAXTOFREE) {yyerror("Too many {quoted} strings"); tfi--;} c=countgetchar(); } yylval->n1->nodetypename=0; yylval->n1->usec=0; yylval->n1->mustbemesh=0; yylval->n1->cxneeded=1; yylval->n1->n1=0; yylval->n1->n2=0; yylval->n1->width32=yylval->width32; yylval->n1->ublo=0; } else yylval->n1=0; yylval->replnum=0; if(yylval->n1) yylval->n1->replnum=c-'0'; else yylval->replnum=c-'0'; yylval->n2=0; return LEXERLEAF; default: return c; } } void treedepthup(YYSTYPE v, bool i) { if(!v) return; treedepthup(v->n1,i); treedepthup(v->n2,i); v->depth++; v->path<<=1; v->path|=i; if(v->depth>30) yyerror("Nesting too deep in template or replacement\n"); } void treefree(YYSTYPE v) { if(!v) return; treefree(v->n1); treefree(v->n2); free(v); } void gennodepath(unsigned depth, unsigned long path) { while(depth--) { if(path&1) printf("->rval"); else printf("->lval"); path>>=1; } } bool treeshapecond(YYSTYPE v, bool firstopt) { if(!v) return firstopt; /* To prevent possibly dereferencing a null pointer, check the root ick_first */ if(v->mustbemesh) /* it's a must-be-constant constraint */ { printf(firstopt?" if((np":" &&\n (np"); gennodepath(v->depth,v->path); printf("->opcode==MESH || np"); gennodepath(v->depth,v->path); printf("->opcode==MESH32)"); firstopt=0; } if(v->condition&&!v->cxneeded) /* it's a tree-shape constraint */ { printf(firstopt?" if(np":" &&\n np"); gennodepath(v->depth,v->path); printf("%s",v->condition); if(v->usec) printf("%luLU",v->c); firstopt=0; } if(v->ublo) /* generate a width check */ { printf(firstopt?" if(np":" &&\n np"); gennodepath(v->depth,v->path); printf("->width==%d",v->width32?32:16); firstopt=0; } firstopt=treeshapecond(v->n1,firstopt); return treeshapecond(v->n2,firstopt); } YYSTYPE treenscheck(YYSTYPE v, YYSTYPE prev, int replnum) { if(!v) return prev; prev=treenscheck(v->n1,prev,replnum); prev=treenscheck(v->n2,prev,replnum); if(v->replnum!=replnum) return prev; if(prev) { printf(" if(!nodessame(np"); gennodepath(prev->depth,prev->path); printf(",np"); gennodepath(v->depth,v->path); printf(")) break;\n"); } return v; } void treecxcond(YYSTYPE v) { if(!v) return; if(v->cxneeded&&strcmp(v->condition,"1")) { if(v->replnum) printf(" x=x%d; c=c%d; ",v->replnum,v->replnum); else { printf(" x=np"); gennodepath(v->depth,v->path); printf("->constant;\n c=np"); gennodepath(v->depth,v->path); printf("->optdata;\n "); } printf("if(!(%s)) break;\n",v->condition); } treecxcond(v->n1); treecxcond(v->n2); } void treerepcount(YYSTYPE v, int* rc) { if(!v) return; if(!(v->nodetypename)&&v->replnum&&!(v->cxneeded)) rc[v->replnum]++; treerepcount(v->n1, rc); treerepcount(v->n2, rc); } void treerepgen(YYSTYPE v, YYSTYPE* refs, int* rc) { if(!v) return; /* We absolutely have to generate the root node ick_first here, because otherwise the nodes in question won't exist. */ if(v->nodetypename) /* Generate an intermediate node */ { printf(" MAYBENEWNODE(tp"); gennodepath(v->depth,v->path); printf(");\n tp"); gennodepath(v->depth,v->path); printf("->opcode=%s;\n tp",v->nodetypename); gennodepath(v->depth,v->path); printf("->width=%d;\n",v->width32?32:16); /* optdata will be filled in by checknodeactbits before the ick_next idiom is tested; constant is irrelevant, lval and rval are NULL at present and will be filled in by later recursions of this function, and I seriously hope that nextslat is never filled in by an optimizer idiom. */ } else if(v->replnum&&!(v->cxneeded)) { /* Copy a node from the template. The node ought not to be allocated at this point, so we can safely just ick_assign to it with a new malloced node. */ if(refs[v->replnum]) { if(rc[v->replnum]>1||!refs[v->replnum]->depth) { /* The node actually has to be copied, either because another copy is needed or because it's np itself that's being copied over. */ rc[v->replnum]--; printf(" tp"); gennodepath(v->depth,v->path); printf("=nodecopy(np"); gennodepath(refs[v->replnum]->depth,refs[v->replnum]->path); printf(");\n"); } else { /* This can be optimized slightly by moving rather than copying, zeroing backlinks so that the node won't be freed. */ rc[v->replnum]--; printf(" tp"); gennodepath(v->depth,v->path); printf("=np"); gennodepath(refs[v->replnum]->depth,refs[v->replnum]->path); printf(";\n np"); gennodepath(refs[v->replnum]->depth,refs[v->replnum]->path); printf("=0;\n"); } } else yyerror("Replacement isn't in the template"); } else if(v->cxneeded) { /* Generate a constant node based on an expression (#{expr}0). */ printf(" MAYBENEWNODE(tp"); gennodepath(v->depth,v->path); printf(");\n tp"); gennodepath(v->depth,v->path); printf("->opcode=MESH32;\n tp"); gennodepath(v->depth,v->path); printf("->width=32;\n tp"); gennodepath(v->depth,v->path); printf("->constant=(%s);\n",v->condition); } else if(v->mustbemesh&&!v->n1) { /* Generate a constant node based on a constant (#65535). */ printf(" MAYBENEWNODE(tp"); gennodepath(v->depth,v->path); printf(");\n tp"); gennodepath(v->depth,v->path); printf("->opcode=MESH32;\n tp"); gennodepath(v->depth,v->path); printf("->width=32;\n tp"); gennodepath(v->depth,v->path); printf("->constant=(%luLU);\n",v->c); } else if(v->mustbemesh&&v->n1) /* let this node's n1 handle it */ ; else yyerror("can't figure out how to generate a replacement node\n"); treerepgen(v->n1,refs,rc); treerepgen(v->n2,refs,rc); } int yyerror(char const *s) { fprintf(stderr,"Error at (%d:%d): \"%s\"\n",cgcrow,cgccol,s); return 0; /* this return value is ignored anyway */ } static int cgcpushback=0; int countgetchar(void) { int c=getchar(); if(cgcpushback) {cgcpushback=0; return c;} cgccol++; if(c=='\n') {cgccol=0; cgcrow++;} return c; } int countungetc(int c, FILE* f) { ungetc(c,f); cgcpushback=1; return c; } void splitstart(void) { static char fname[]="oilout00.c"; FILE *dummy; /* GCC 4 un-suppressable warning suck */ if(filenumber>255) { filenumber=255; fprintf(stdout,"Input file too long.\n"); } sprintf(fname,"oilout%02x.c",filenumber); dummy = freopen(fname,"w",stdout); puts("/* Automatically generated output, edit source and recompile to " "change */"); printf("#include \"oil.h\"\n" "int optimize_pass1_%x(node *np)\n" "{" " int opted=0;\n" " unsigned long c,c1,c2,c3,c4,c5,c6,c7,c8,c9;\n" " unsigned long x,x1,x2,x3,x4,x5,x6,x7,x8,x9,r;\n" " int tempw;\n" " node *tp;\n", filenumber); } void splitend(void) { /* Disabling warnings about unused variables. gcc will optimize this right out, and in any case the raise(SIGSEGV) will be unreachable (but will cause a pretty recognizable error because it'll be caught by the handler for SIGSEGV and output an internal error, with an obvious debug backtrace if -U is used). */ printf(" c=c1=c2=c3=c4=c5=c6=c7=c8=c9=0;\n" " x=x1=x2=x3=x4=x5=x6=x7=x8=x9=r=0;\n" " if(c+c1+c2+c3+c4+c5+c6+c7+c8+c9+r+\n" " x+x1+x2+x3+x4+x5+x6+x7+x8+x9) raise(SIGSEGV);\n"); printf(" return opted;\n}\n"); /* do not close stdout; freopen implicitly closes it anyway, and explicitly closing it breaks on DOS */ } int main(void) { int e,i; FILE *dummy; /* GCC 4 un-suppressible warnings suck */ /* " if(!np) return 0;\n" " if(np->lval) opted|=optimize_pass1(np->lval);\n" " if(np->rval) opted|=optimize_pass1(np->rval);\n" */ splitstart(); cgccol=0; cgcrow=1; e=yyparse(); while(tfi--) free(tofree[tfi]); splitend(); dummy = freopen("oilout-m.c","w",stdout); puts("/* Automatically generated output, edit source and recompile to " "change */"); puts("#include \"config.h\""); puts("#include \"ick.h\""); i=filenumber+1; while(i--) printf("extern int optimize_pass1_%x(node*);\n",i); puts("int optimize_pass1(node* np)\n" "{\n" " int opted=0;\n" " if(!np) return 0;\n" " if(np->lval) opted|=optimize_pass1(np->lval);\n" " if(np->rval) opted|=optimize_pass1(np->rval);"); i=filenumber+1; while(i--) printf(" opted|=optimize_pass1_%x(np);\n",i); puts(" return opted;\n" "}"); return e; } intercal-0.29/src/atari.bin0000644000175000017500000000021711435477314015513 0ustar brooniebroonie128 1 xgfedcba   !"#¢%&'()*+,-./0123456789:;<=>¥?ABCDEFGHIJKLMNOPQRSTUVWXYZ[\]|@`abcdefghijklmnopqrstuvwxyz{}~intercal-0.29/src/ick_lose.h0000644000175000017500000002621511443403052015653 0ustar brooniebroonie/* ick_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 IE632, 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", ick_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 IE000 "000 %s\n\ ON THE WAY TO %d\n" /* An expression contains a syntax error. */ #define IE017 "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 IE079 "079 PROGRAMMER IS INSUFFICIENTLY POLITE\n\ ON THE WAY TO %d\n" /* Improper use has been made of statement identifiers. */ #define IE099 "099 PROGRAMMER IS OVERLY POLITE\n\ ON THE WAY TO %d\n" /* Program has attempted 80 levels of NEXTing */ #define IE123 "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 IE129 "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 IE139 "139 I WASN'T PLANNING TO GO THERE ANYWAY\n\ ON THE WAY TO %d\n" /* A line label has been multiply defined. */ #define IE182 "182 YOU MUST LIKE THIS LABEL A LOT!\n\ ON THE WAY TO %d\n" /* An invalid line label has been encountered. */ #define IE197 "197 SO! 65535 LABELS AREN'T ENOUGH FOR YOU?\n\ ON THE WAY TO %d\n" /* An expression involves an unidentified variable. */ #define IE200 "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 IE240 "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 IE241 "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 IE275 "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 IE436 "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 IE533 "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 IE562 "562 I DO NOT COMPUTE\n\ ON THE WAY TO %d\n" /* Input data is invalid. */ #define IE579 "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 IE621 "621 ERROR TYPE 621 ENCOUNTERED\n\ ON THE WAY TO %d\n" /* Program execution terminated via a RESUME statement instead of GIVE UP. */ #define IE632 "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 IE633 "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 IE774 "774 RANDOM COMPILER BUG\n\ ON THE WAY TO %d\n" /* An unexplainable compiler error has occurred (see J. Lyon or D. Woods). */ #define IE778 "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 `ick_traditional' flag on */ #define IE111 "111 COMMUNIST PLOT DETECTED, COMPILER IS SUICIDING\n\ ON THE WAY TO %d\n" /* Cannot find the magically included system library */ #define IE127 "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 IE222 "222 BUMMER, DUDE!\n\ ON THE WAY TO %d\n" /* (AIS) Out of memory during I/O */ #define IE252 "252 I'VE FORGOTTEN WHAT I WAS ABOUT TO SAY\n\ ON THE WAY TO %d\n" /* (AIS) Can't reverse an expression in an assignment. This is the same error number as in CLC-INTERCAL, but the message is different. */ #define IE277 "277 YOU CAN ONLY DISTORT THE LAWS OF MATHEMATICS SO FAR\n\ ON THE WAY TO %d\n" /* (AIS) The spark/ears nesting is too deep. */ #define IE281 "281 THAT MUCH QUOTATION AMOUNTS TO PLAGIARISM\n\ ON THE WAY TO %d\n" /* Too many variables. */ #define IE333 "333 YOU CAN'T HAVE EVERYTHING, WHERE WOULD YOU PUT IT?\n\ ON THE WAY TO %d\n" /* Out of memory during compilation. */ #define IE345 "345 THAT'S TOO COMPLEX FOR ME TO GRASP\n\ ON THE WAY TO SOMEWHERE\n" /* (AIS, from the suggestion by Malcom Ryan) GO BACK or GO AHEAD was executed without a choicepoint. */ #define IE404 "404 I'M ALL OUT OF CHOICES!\n\ ON THE WAY TO %d\n" /* (AIS) WHILE, MAYBE, GO BACK, or GO AHEAD used without the -m option. */ #define IE405 "405 PROGRAM REJECTED FOR MENTAL HEALTH REASONS\n\ ON THE WAY TO %d\n" /* A COME FROM statement references a non-existent line label. */ #define IE444 "444 IT CAME FROM BEYOND SPACE\n\ ON THE WAY TO %d\n" /* (AIS) We just buffer-overflowed. (Detecting this /before/ the overflow happens is probably more secure, but harder and less fun. As long as we don't return from any functions, it's probably safe in theory, but don't rely on this. */ #define IE553 "553 BETTER LATE THAN NEVER\n\ ON THE WAY TO %d\n" /* More than one COME FROM references the same label. */ #define IE555 "555 FLOW DIAGRAM IS EXCESSIVELY CONNECTED\n\ ON THE WAY TO %d\n" /* Too many source lines, or too many input files, or source line is too long. */ #define IE666 "666 COMPILER HAS INDIGESTION\n\ ON THE WAY TO %d\n" /* No such source file. */ #define IE777 "777 A SOURCE IS A SOURCE, OF COURSE, OF COURSE\n\ ON THE WAY TO %d\n" /* Can't open C output file */ #define IE888 "888 I HAVE NO FILE AND I MUST SCREAM\n\ ON THE WAY TO %d\n" /* Can't open C skeleton file. */ #define IE999 "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 IE998 "998 EXCUSE ME,\n\ YOU MUST HAVE ME CONFUSED WITH SOME OTHER COMPILER\n" /* (AIS) File used of a type for which the required libraries aren't available. */ #define IE899 "899 HELLO?\n\ CAN ANYONE GIVE ME A HAND HERE?\n" /* Illegal possession of a controlled unary operator. */ #define IE997 "997 ILLEGAL POSSESSION OF A CONTROLLED UNARY OPERATOR.\n\ ON THE WAY TO %d\n" /* (AIS) Command found after TRY AGAIN. */ #define IE993 "993 I GAVE UP LONG AGO\n\ ON THE WAY TO %d\n" /* (AIS) Memory allocation failure during multithreading */ #define IE991 "991 YOU HAVE TOO MUCH ROPE TO HANG YOURSELF\n\ ON THE WAY TO %d\n" /* (AIS) Unimplemented feature used. This should never come up, hopefully. */ #define IE995 "995 DO YOU REALLY EXPECT ME TO HAVE IMPLEMENTED THAT?\n\ ON THE WAY TO %d\n" /* Unknown invocation flag */ #define IE990 "990 FLAG ETIQUETTE FAILURE BAD SCOUT NO BISCUIT.\n\ ON THE WAY TO %d\n" /* Code generator encountered an unknown opcode in a tuple */ #define IE994 "994 NOCTURNAL EMISSION, PLEASE LAUNDER SHEETS IMMEDIATELY.\n\ ON THE WAY TO %d\n" /* * AIS: These errors are specific to PIC-INTERCAL */ /* (AIS) Attempted to use an unsupported language feature. */ #define IE256 "256 THAT'S TOO HARD FOR MY TINY BRAIN\n\ ON THE WAY TO %d\n" /* (AIS) Attempted to use a PIC feature in a non-PIC program. */ #define IE652 "652 HOW DARE YOU INSULT ME!\n\ ON THE WAY TO %d\n" /* * AIS: These errors are generated by the yuk debugger */ /* (AIS) fgets' buffer overflowed on debugger comand input. */ #define IE810 "810 ARE ONE-CHARACTER COMMANDS TOO SHORT FOR YOU?\n\ ON THE WAY TO %d\n" /* (AIS) Too many breakpoints. */ #define IE811 "811 PROGRAM IS TOO BADLY BROKEN TO RUN\n\ ON THE WAY TO %d\n" /* * (AIS) Warnings produced by -l. */ /* (AIS) Non-INTERCAL-72 identifier used. */ #define W112 "112 THAT RELIES ON THE NEW WORLD ORDER\n\ ON THE WAY TO %d\n" /* (AIS) That stupid idiom in syslib was used. */ #define W128 "128 SYSLIB IS OPTIMIZED FOR OBFUSCATION\n\ ON THE WAY TO %d\n" /* (AIS) Possibly nonportable unary operator. */ #define W534 "534 KEEP LOOKING AT THE TOP BIT\n\ ON THE WAY TO %d\n" /* (AIS) Expression still contains INTERCAL operators after optimization. Only in binary, because this nearly always happens in the higher bases. Syslib causes quite a lot of these. This warning is fine on INTERCAL-like lines, but flags a mistake on lines that are meant to be translations of C. */ #define W018 "018 THAT WAS MEANT TO BE A JOKE\n\ ON THE WAY TO %d\n" /* (AIS) Possible misplaced unary operator. At the moment, ick -l cannot detect this condition (so it never comes up). It's meant to detect expressions like '?"?.1~#256"$#2'~#3 (from numio.i); in this expression, the second what has no effect (it changes only the msb of the immediately surrounding expression, which is eventually filtered out by the select against #3). But detecting this would probably require code that could check which bits of a result were going to be used elsewhere in an expression, which is something I haven't written yet (but would make a decent optimize_pass3). */ #define W016 "016 DON'T TYPE THAT SO HASTILY\n\ ON THE WAY TO %d\n" /* (AIS) Possibly overflowing assignment or ick_mingle. Syslib causes some of these too, in complicated situations where the bugcatcher can't figure out what's happening, and also in a few blatant statements in the mould of DO .3 <- :3, which are quite clearly possible overflows. Strangely enough, there's a commented-out section of code in feh.c that suggests that someone tried to make this an error (using a more general check which would have caught more correct code involving GETS, but none involving $). As a middle ground, I've made it an -l warning. */ #define W276 "276 YOU CAN'T EXPECT ME TO CHECK BACK THAT FAR\n\ ON THE WAY TO %d\n" /* (AIS) A line will inevitably cause an expression-reversal failure. */ #define W278 "278 FROM A CONTRADICTION, ANYTHING FOLLOWS\n\ ON THE WAY TO A HUGE DISASTER\n" /* (AIS) The two following warnings are both compile-time traps for near-certain runtime errors. As such, they have similar numbers and similar messages. In fact, they're a shameless ripoff of the originals, but should serve as a reminder for anyone aware of the original messages. */ /* (AIS) Dimension given for an ick_array will come out as #0. */ #define W239 "239 WARNING HANDLER PRINTED SNIDE REMARK\n\ ON THE WAY TO %d\n" /* (AIS) RESUME argument will come out as #0. */ #define W622 "622 WARNING TYPE 622 ENCOUNTERED\n\ ON THE WAY TO %d\n" extern int ick_lineno; extern void /*@noreturn@*/ ick_lose(const char *m, int n, /*@null@*/ const char *s) #ifdef __GNUC__ __attribute__ ((noreturn)) #endif ; extern void ick_lwarn(const char *m, int n, /*@null@*/ const char *s); /* ick_lose.h ends here */ intercal-0.29/src/abcessh.in0000644000175000017500000002106511450066647015665 0ustar brooniebroonie/* abcess.h -- functions used by compiled INTERCAL programs -*- c -*- */ /* This file is generated from abcessh.in */ /* AIS note: This header file now serves two purposes. For non-multithread programs, it serves as headers to the degenerated code and many support functions. For multithread programs, this header file adds extra functions only when compiling the degenerated code and unravel.c, and holds its previous contents during other files. */ #include #include #include /* We use the +1 trick here, as it works whether the values substituted in are the null string, 0, or positive. */ #ifndef HAVE_STDBOOL_H # define HAVE_STDBOOL_H @HAVE_STDBOOL_H@ + 1 # if HAVE_STDBOOL_H == 1 # undef HAVE_STDBOOL_H # endif #endif #ifndef HAVE__BOOL # define HAVE__BOOL @HAVE__BOOL@ + 1 # if HAVE__BOOL == 1 # undef HAVE__BOOL # endif #endif #ifndef HAVE_STDINT_H # define HAVE_STDINT_H @HAVE_STDINT_H@ + 1 # if HAVE_STDINT_H == 1 # undef HAVE_STDINT_H # endif #endif /* * Duplicates contents of ick_bool.h. Someday maybe we'll install this * and avoid such grottiness. */ /*@-redef@*/ #ifndef __bool_true_false_are_defined # if HAVE_STDBOOL_H >= 1 # include # else # ifndef HAVE__BOOL >= 1 # ifdef HAVE_STDINT_H >= 1 # include typedef int_fast8_t bool; # else typedef int bool; # endif # else typedef _Bool bool; # endif # define true 1 # define false 0 # define __bool_true_false_are_defined 1 # endif #endif /*@=redef@*/ #define ICK_ABCESS_H_INCLUDED #define ick_ONESPOT 0 #define ick_TWOSPOT 1 #define ick_TAIL 2 #define ick_HYBRID 3 #define ick_MAXNEXT 80 /* AIS: Moved from cesspool.c */ /* the following two types must both promote to unsigned int in expressions */ typedef unsigned short ick_type16; typedef unsigned int ick_type32; typedef struct ick_array_t { unsigned int rank; size_t *dims; union { ick_type16 *tail; ick_type32 *hybrid; } data; } ick_array; /* AIS: For operand overloading, a more complicated data type is needed. */ typedef struct ick_overop_t { ick_type32 (*get)(ick_type32); void (*set)(ick_type32, void(*)()); } ick_overop; /* AIS: Moved from cesspool.c */ typedef struct ick_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 */ { ick_type16 onespot; ick_type32 twospot; ick_array *a; } save; /*@null@*/ /*@dependent@*/ struct ick_stashbox_t *ick_next; /* pointer to next-older ick_stashbox */ ick_overop overloadinfo; /* AIS: overloading info is stashed too, in a non-overloaded program (ignored otherwise) */ } ick_stashbox; /* AIS: files to take input and output from */ /*@null@*/ extern FILE* ick_cesspoolin; /*@null@*/ extern FILE* ick_cesspoolout; /* defined in cesspool.c */ extern void ick_pushnext(unsigned n); extern unsigned int ick_popnext(unsigned n); extern unsigned int ick_resume(unsigned n); extern unsigned int ick_pin(void); extern void ick_clockface(bool mode); extern void ick_setclcsemantics(bool mode); /* AIS */ extern void ick_pout(unsigned int val); extern void ick_binin(unsigned int type, ick_array *a, bool forget); extern void ick_binout(unsigned int type, const ick_array *a); extern unsigned int ick_assign(char *dest, unsigned int type, bool forget, unsigned int value); /* AIS: yuk, unravel and ick_ec need these */ extern unsigned* ick_next; /*@null@*/ extern jmp_buf* ick_next_jmpbufs; extern int ick_nextindex; extern /*@null@*/ ick_stashbox *ick_first; /* AIS: Implement the +ick_mystery command line option. */ extern unsigned long ick_mysteryc; extern int ick_mystery; #define ick_MYSTERYLINE if(ick_mystery && ick_mysteryc++ > 4000000000LU) exit(42); /* AIS: More command-line options */ extern int ick_wimp_mode; extern int ick_instapipe; /* AIS: Handle multiple COME FROMs aiming at the same line */ extern int ick_multicome0(int errlineno, jmp_buf pc); #ifdef HAVE_STDARG_H /*@dependent@*/ extern void *ick_aref(unsigned int type, ...); extern void ick_resize(unsigned int type, ...); #else /*@dependent@*/ extern void *ick_aref(); extern void ick_resize(); #endif extern void ick_stashinit(void); /* AIS: Added mentions of oo. This is set to 0 in a non-overloaded program. */ extern void ick_stash(unsigned int type, unsigned int index, void *from, ick_overop* oo); extern void ick_retrieve(void *to, unsigned int type, unsigned int index, bool forget, ick_overop* oo); extern unsigned int ick_roll(unsigned int n); /* AIS: Lose with IE277 */ extern ick_type32 ick_ieg277(ick_type32); extern void ick_ies277(ick_type32, void(*)()); /* defined in arrgghh.c */ extern void ick_parseargs(int argc, char **argv); extern int ick_printflow; /* AIS: For the CREATE statement */ typedef struct ick_tag_createdata ick_createdata; struct ick_tag_createdata { int width; /* 16 or 32 (maybe 0 will be allowed at some point) */ int isarray; /* this and the previous determine what vartype it is */ unsigned short varnumber; /* 0 if not a variable, the var's number if it is */ ick_overop accessors;/* how to get and set this lvalue, or {0,0} */ unsigned long value; /* current value of the var or expression */ }; extern void ick_registercreation(const char*,unsigned long); extern unsigned long ick_jicmatch(const char*); /* AIS: Multithreading types and defines */ #if MULTITHREAD != 0 typedef struct tag_ickthread ickthread; /*@refcounted@*/ struct tag_ickthread { void* varforget[10]; /* holds all four variable types, and forgetting data */ unsigned* nextstack; int nextpointer; jmp_buf pc; /* program counter */ ick_stashbox* sb; /* holds all stash data */ /*@partial@*/ /*@dependent@*/ ickthread* ick_next; /*@null@*/ /*@partial@*/ /*@dependent@*/ ickthread* choicepoint; /* the top choicepoint available. Used as a next pointer in the choicepoint stack. */ int stale; /* if this is a choicepoint, whether it's a stale choicepoint. */ int refcount; /* when Threaded INTERCAL and Backtracking INTERCAL are combined, reference-counting on choicepoints is needed so that backtracking past multithreading is possible. This also allows for garbage-collection of choicepoints. (Luckily, choicepoints cannot refer to themselves, so this mechanism works.) This only applies to ickthreads that are acting as choicepoints, not those acting as threads. */ int ick_ccfc; /* number of comefroms currently active */ long ick_skipto; /* compucome line number */ jmp_buf ick_cjb; /* keeps track of compucomes */ /*@partial@*/ /*@dependent@*/ ickthread* dsi; /* which thread's varforget and sb to use */ /*@null@*/ /*@dependent@*/ ickthread* usesthis; /* for garbage collection purposes */ }; /*@partial@*/ /*@dependent@*/ extern ickthread* ickmt_cur; /* current thread */ /*@partial@*/ /*@dependent@*/ extern ickthread*ickmt_prev; /* previous thread: an optimisation to make thread switching O(1), not O(n), with respect to the number of threads */ extern int weaving; /* whether to weave newly created threads */ #define NEXTTHREAD if(ick_printflow) fprintf(stderr,"[%d:%lx]",ick_lineno, \ (unsigned long)ickmt_cur); \ if(setjmp(ick_cjb) == 0) \ nextthread(ick_cjb, ick_lineno, 3); extern void nextthread(jmp_buf pc, int errlineno, int flags); extern void killthread(void); extern void ickmtinit(void); extern int multicome1(int errlineno, jmp_buf pc); extern void choicepoint(void); extern void choiceahead(void); extern void choiceback(void); /* from ick-wrap.c, declare as extern so they can be accessed by cesspool.c, unravel.c */ extern int onespotcount; extern int twospotcount; extern int tailcount; extern int hybridcount; extern int ick_oldabstain; extern int gonebackto; extern int ick_ccfc; extern long ick_skipto; extern jmp_buf btjb; extern jmp_buf ick_cjb; #define MULTICOME multicome1 #else #define MULTICOME ick_multicome0 #endif /* MULTITHREAD */ /* AIS: Used by the debugger, multithread code, external calls */ #if (MULTITHREAD != 0) || (YUKDEBUG != 0) || defined(ICK_EC) extern ick_type16* ick_onespots; extern bool* ick_oneforget; extern ick_type32* ick_twospots; extern bool* ick_twoforget; extern ick_array* ick_tails; extern bool* ick_tailforget; extern ick_array* ick_hybrids; extern bool* ick_hyforget; #if (MULTITHREAD != 0) || defined(ICK_EC) /*@null@*/ extern ick_overop* ick_oo_onespots; /*@null@*/ extern ick_overop* ick_oo_twospots; #endif #endif /* abcess.h ends here */ intercal-0.29/src/bin2c.c0000644000175000017500000000301311443403052015042 0ustar brooniebroonie/***************************************************************************** NAME bin2c.c -- convert a binary data file to a C source file LICENSE TERMS Copyright (C) 2007 Alex Smith 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 int main(int argc, char** argv) { int c,colno; if(argc!=2) { fprintf(stderr,"Usage: bin2c varname < infile > outfile\n"); return 0; } (void) puts("/* This file is automatically generated; to modify it,"); (void) puts(" modify the source file, not this file. */"); (void) puts("#include \"config.h\""); printf("const char* %s=\"\\\n",argv[1]); colno=0; while((c=getchar())!=EOF) { printf("\\x%02x",(unsigned)c); colno+=4; if(colno>70) {(void) puts("\\"); colno=0;} } (void) puts("\";"); return 0; } intercal-0.29/src/ick_ec.h0000644000175000017500000002366611443403052015307 0ustar brooniebroonie/***************************************************************************** NAME ick_ec.h -- external call support between C and C-INTERCAL LICENSE TERMS Copyright (C) 2008 Alex Smith 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. ***************************************************************************/ /* The external calls to C work via ICK_EC_FUNCs; whenever a suckpoint is encountered, all ICK_EC_FUNCs are run with ick_global_checkmode set to 1, and when a NEXT is called but finds no target in the INTERCAL program, all ICK_EC_FUNCs are run with ick_global_checkmode set to 2. COME FROMs and NEXT FROMs don't steal control immediately (they know where to steal control from using ick_global_linelabel), but instead set ick_global_goto to a 'high' line label (one of the internal ones above 65536 which are allocated for this sort of purpose, and inside the preprocessor) or error if it's set nonzero already. After verifying that exactly one COME or NEXT FROM is involved, the INTERCAL program will NEXT to the high line label (whether it leaves a NEXT stack entry will depend on whether COME FROM or NEXT FROM was used, which is communicated by a NEXT FROM setting the checkmode to 3, which is identical to 1 in all other respects). To prevent this process running the program out of stack space (which would happen with a naive implementation if there were many COME FROMs from inside the C program back to inside the C program), all transitions but NEXTs are done indirectly, by jumping back inside a relevant invocation of ick_dogoto and changing its targets. (So effectively, to GOTO a particular destination, you go back in time to the last time you NEXTed - or to implement a FORGET, the last-but-n-time you NEXTed - and redo it with a different target.) */ #if ICK_HAVE_STDINT_H+1 == 2 #include #else /* Ensure that uint32_t, etc, aren't implemented as compatibility macros so that we can implement them as typedefs. */ #undef uint32_t #undef uint16_t typedef unsigned int uint32_t; typedef unsigned short uint16_t; #endif #ifndef ICK_ABCESS_H_INCLUDED typedef unsigned short ick_type16; typedef unsigned int ick_type32; #endif #define ICK_EC_FUNC_START(id) \ ICK_EC_PP_0(id) \ void id(void) \ { \ void* ick_local_createdata = \ ick_global_createdata; \ int ick_local_checkmode = ick_global_checkmode; \ if(ick_global_checkmode==6) \ { \ goto ick_l6_ICK_EC_PP_6; \ } \ if(ick_global_checkmode==2) \ { \ goto ick_l2_ICK_EC_PP_2; \ } \ else if(ick_global_checkmode==1 || \ ick_global_checkmode==3) \ { \ goto ick_l1_ICK_EC_PP_1; \ } \ ick_local_checkmode=ick_global_checkmode=0; #define ick_linelabel(expr) ick_labeledblock(expr,0) #define ick_labeledblock(expr,block) \ do { \ if(0) \ { \ ick_l2_ICK_EC_PP_2: ; \ if(ick_global_linelabel != (expr) || (expr) > 65535) \ goto ick_l2_ICK_EC_PP_2; \ ick_global_checkmode = 0; \ } \ block ; \ ick_checksuckpoint(expr); \ } \ while(0) #define ick_linelabelnosp(expr) \ do { \ if(0) \ { \ ick_l2_ICK_EC_PP_2: ; \ if(ick_global_linelabel != (expr) || (expr) > 65535) \ goto ick_l2_ICK_EC_PP_2; \ ick_global_checkmode = 0; \ } \ } \ while(0) #define ick_forget(amount) \ do { \ ick_scheduleforget(amount); \ ick_dogoto(ICK_EC_PP_3,-1,0); \ ick_lose(ICK_IE778, -1, (char*) NULL); \ return; \ ick_l2_ICK_EC_PP_2: ; \ if(ick_global_linelabel != ICK_EC_PP_3) \ goto ick_l2_ICK_EC_PP_2; \ ick_global_checkmode = 0; \ } while(0) #define ick_startup(block) \ if(0) \ { \ ick_l6_ICK_EC_PP_6: \ ick_global_checkmode=0; \ block ; \ ick_global_checkmode=ick_local_checkmode; \ goto ick_l6_ICK_EC_PP_6; \ } #define ick_comefrom(expr) \ if(0) \ { \ ick_l1_ICK_EC_PP_1: ; \ if(ick_global_linelabel == (expr) && (expr) <= 65535) \ { \ if(ick_global_goto) ick_lose(ICK_IE555, -1, (char*)0); \ ick_global_goto = ICK_EC_PP_3; \ } \ goto ick_l1_ICK_EC_PP_1; \ ick_l2_ICK_EC_PP_2: ; \ if(ick_global_linelabel != ICK_EC_PP_3) \ goto ick_l2_ICK_EC_PP_2; \ ick_global_checkmode = 0; \ } #define ick_comefromif(expr,condition) \ ick_docomefromif(expr,-1,condition) #define ick_docomefromif(expr,lbl,condition) \ if(0) \ { \ ick_l1_ICK_EC_PP_1: ; \ if(ick_global_linelabel == (expr) && (expr) <= 65535) \ if(condition) \ { \ if(ick_global_goto) ick_lose(ICK_IE555, lbl, (char*)0); \ ick_global_goto = ICK_EC_PP_3; \ } \ goto ick_l1_ICK_EC_PP_1; \ ick_l2_ICK_EC_PP_2: ; \ if(ick_global_linelabel != ICK_EC_PP_3) \ goto ick_l2_ICK_EC_PP_2; \ ick_global_checkmode = 0; \ } #define ick_nextfrom(expr) \ if(0) \ { \ ick_l1_ICK_EC_PP_1: ; \ if(ick_global_linelabel == (expr) && (expr) <= 65535) \ { \ if(ick_global_goto) ick_lose(ICK_IE555, -1, (char*)0); \ ick_global_goto = ICK_EC_PP_3; \ ick_global_checkmode = 3; \ } \ goto ick_l1_ICK_EC_PP_1; \ ick_l2_ICK_EC_PP_2: ; \ if(ick_global_linelabel != ICK_EC_PP_3) \ goto ick_l2_ICK_EC_PP_2; \ ick_global_checkmode = 0; \ } #define ick_nextfromif(expr,condition) \ ick_donextfromif(expr,-1,condition) #define ick_donextfromif(expr,lbl,condition) \ if(0) \ { \ ick_l1_ICK_EC_PP_1: ; \ if(ick_global_linelabel == (expr) && (expr) <= 65535) \ if(condition) \ { \ if(ick_global_goto) ick_lose(ICK_IE555, lbl, (char*)0); \ ick_global_goto = ICK_EC_PP_3; \ ick_global_checkmode = 3; \ } \ goto ick_l1_ICK_EC_PP_1; \ ick_l2_ICK_EC_PP_2: ; \ if(ick_global_linelabel != ICK_EC_PP_3) \ goto ick_l2_ICK_EC_PP_2; \ ick_global_checkmode = 0; \ } #define ICK_EC_FUNC_END \ if(ick_local_checkmode) ick_resume(1); \ ick_l1_ICK_EC_PP_1: ; \ ick_l6_ICK_EC_PP_6: ; \ ick_l2_ICK_EC_PP_2: return; \ } #define ick_next(label) do{ \ if((label)<=65535) \ ick_dogoto((label),-1,1); \ } while(0) #define ick_goto(label) do{ \ if((label)<=65535) \ ick_dogoto((label),-1,0); \ } while(0) #define ick_resume(amount) ick_doresume((amount),-1) #define ick_return_or_resume() do{ \ if(ick_local_checkmode) ick_doresume(1,-1); \ return; \ } while(0) /*@maynotreturn@*/ void ick_dogoto(unsigned long, int, int); void ick_scheduleforget(unsigned short); /*@noreturn@*/ void ick_doresume(unsigned short, int); /*@maynotreturn@*/ void ick_checksuckpoint(unsigned long); void ick_runstartups(void); /*@maynotreturn@*/ uint32_t ick_dounop(char*, uint32_t, uint32_t, int, unsigned long, unsigned long, unsigned long, ick_type32(*)(ick_type32), ick_type32(*)(ick_type32), ick_type32(*)(ick_type32), void(*)(ick_type32, void(*)()), void(*)(ick_type32, void(*)()), void(*)(ick_type32, void(*)()), /*@observer@*/ const char*); void ick_allecfuncs(void); /* in generated program */ extern int ick_global_checkmode; extern unsigned long ick_global_linelabel; extern unsigned long ick_global_goto; extern void* ick_global_createdata; /* Variables. */ typedef struct ick_ec_var_tag { int ick_ec_vartype; int ick_ec_extername; int ick_ec_intername; } ick_ec_var; extern ick_ec_var ick_ec_vars[]; #define ICK_EC_VARS_END 5 uint16_t ick_getonespot(unsigned short); void ick_setonespot(unsigned short, uint16_t); uint32_t ick_gettwospot(unsigned short); void ick_settwospot(unsigned short, uint32_t); void ick_create(const char*, unsigned long); /* For accessing the arguments to an ick_created command */ int ick_c_i_width(int); int ick_c_i_isarray(int); unsigned short ick_c_i_varnumber(int); uint32_t ick_c_i_value(int); /* These require -a to work */ uint32_t ick_c_i_getvalue(int); void ick_c_i_setvalue(int, uint32_t); #define ick_c_width(a) ick_c_i_width((ick_global_createdata=ick_local_createdata,(a))) #define ick_c_isarray(a) ick_c_i_isarray((ick_global_createdata=ick_local_createdata,(a))) #define ick_c_varnumber(a) ick_c_i_varnumber((ick_global_createdata=ick_local_createdata,(a))) #define ick_c_value(a) ick_c_i_value((ick_global_createdata=ick_local_createdata,(a))) #define ick_c_getvalue(a) ick_c_i_getvalue((ick_global_createdata=ick_local_createdata,(a))) #define ick_c_setvalue(a,n) ick_c_i_setvalue((ick_global_createdata=ick_local_createdata,(a)),(n)) /* Fragments of ick_lose.h, that don't impinge on unmangled namespace. */ #define ICK_IE555 "555 FLOW DIAGRAM IS EXCESSIVELY CONNECTED\n\ ON THE WAY TO %d\n" #define ICK_IE778 "778 UNEXPLAINED COMPILER BUG\n\ ON THE WAY TO %d\n" extern void /*@noreturn@*/ ick_lose(const char *m, int n, /*@null@*/ const char *s) #ifdef __GNUC__ __attribute__ ((noreturn)) #endif ; intercal-0.29/src/ick_lose.c0000644000175000017500000000440011443403272015642 0ustar brooniebroonie/* * * NAME * ick_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 "config.h" #include #include #include #include "ick.h" /* ugh, just for bool */ #include "ick_lose.h" bool ick_coreonerr; /* AIS */ bool ick_checkforbugs; /* AIS */ /*@-formatconst@*/ void ick_lose(const char *m, int n, const char *s) { (void) fflush(stdout); /* AIS: To stop stdout getting muddled with stderr*/ (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"); if(atoi(m)==778&&ick_coreonerr) /* AIS */ { /* AIS: Dump core. */ (void) raise(SIGABRT); } exit(atoi(m)); } /* AIS: This function reports potential bugs. It's paraphrased from ick_lose. */ void ick_lwarn(const char *m, int n, const char *s) { if(!ick_checkforbugs) return; /* Don't report a potential bug without -l */ (void) fflush(stdout); (void) fprintf(stderr, "ICL%c%c%cW\t", m[0],m[1],m[2]); if (s) (void) fprintf(stderr, m + 4, s, n); else if(m[0]!='2'||m[1]!='7'||m[2]!='8') (void) fprintf(stderr, m + 4, n); else (void) fputs(m + 4, stderr); (void) fputs(" RECONSIDER SOURCE AND RESUBNIT\n\n", stderr); /* Don't exit. This is not any error except one not causing immediate termination of program execution. */ } /*@=formatconst@*/ /* ick_lose.c ends here */ intercal-0.29/src/arrgghh.c0000644000175000017500000000701611443403052015476 0ustar brooniebroonie/* * SYNOPSIS: ick_parseargs(argc,argv) * FILE : ick_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 "config.h" #include "abcess.h" #include "ick_lose.h" /*@-redef@*/ /* it's never the case that both are used at once */ int ick_traditional = 0; /*@=redef@*/ int ick_wimp_mode = 0; int ick_instapipe = 0; /* AIS */ int ick_printflow = 0; /* AIS */ int ick_mystery = 0; /* AIS */ unsigned long ick_mysteryc = 0; /* AIS */ void ick_parseargs(int argc, char **argv) { register int i, j; static int helpflag = -1; static const char *flags[] = { "help", "wimpmode", "traditional", "instapipe", /* AIS */ "printflow", /* AIS */ "mystery", /* AIS */ }; static int *bools[] = { &helpflag, &ick_wimp_mode, &ick_traditional, &ick_instapipe, /* AIS */ &ick_printflow, /* AIS */ &ick_mystery, /* AIS */ }; static const 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"); } 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"); (void) fflush(stderr); ick_lose(IE990, 0, (const char *)NULL); } if(ick_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"); (void) fflush(stderr); } } intercal-0.29/src/unravel.c0000644000175000017500000010115711435477314015546 0ustar brooniebroonie/***************************************************************************** NAME unravel.c -- multithreading and backtracking support for C-INTERCAL LICENSE TERMS Copyright (C) 2006 Alex Smith 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. ***************************************************************************/ /* Notes about authorship. This entire file was written by Alex Smith (AIS), but with reference to an earlier implementation of Threaded INTERCAL written by Malcom Ryan. I have not reused any of his C code (two of his INTERCAL programs are in the pit), but it was a useful source of inspiration, even though I did it a completely different and less efficient way (I think we handled mutiple COME FROM recognition in much the same way). This file only contains functions necessary for multithreading; some of the code is stored in feh2.c (stored in strings), or in perpet.c (again stored in strings). The information about the required syntax is in parser.y and lexer.l. A small amount of the multithread code is in ick-wrap.c, although as that file is copied almost verbatim (although it's quite a big 'almost') into all ick output, it's guarded there by #if...#endif. The whole multithread idea started on alt.lang.intercal when it was noticed that multiple COME FROMs aiming at the same line were hard to interpret, but I would like to thank Malcom Ryan for drafting the Threaded Intercal standard and a reference compiler, and for turning the idea into a concrete set of rules. (The standard itself carries a note saying that a revision (use of AGAIN) was inspired by Kyle Dean, so I'd like to mention that here too, and I also revised it (so that ABSTAIN/REINSTATE were preserved through backtracking).) In terms of the quality of the code, Malcom Ryan's code was clearly better for multithread programs, but required rewriting most of the compiler. As clearly it would be unfair to subject the INTERCAL community at large to the risk of silent multithreading by default, I decided multithreading should be off by default (but ONCE/AGAIN should be legal). So this code is designed to interfere as little as possible with non-multithreaded output. There are two versions of libick compiled by the Makefile in this distribution: libick.a, the non-multithread version, and libickmt.a, the multithread version. The only difference between them is this file, unravel.c, which is multithread only, so it seemed a good place for this comment. To see what the multithreading looks like in the object code, see degenerated code or feh2.c. */ /* This file also implements Backtracking INTERCAL, which is turned on with the same command-line option (-m). This implementation differs from Malcom Ryan's standard in that abstention stati are not restored upon GOING BACK. As far as I know, this is the only Backtracking INTERCAL implementation currently available, although the code depends on the multithreading code (which is why -m is neccesary). */ /* Note about control structures: Crazy INTERCAL control structures call for crazy C control structures. setjmp/longjmp is probably C's weirdest control structure (it's sort of like a time-reversed computed COME FROM). I've used them to implement both multithreading and computed COME FROMming. Worried that this code might actually be copied by a casual C programmer, I have the following warning: setjmp/longjmp is worse than goto in terms of spaghettification of code. It is strictly to be used only when neccesary, or when writing INTERCAL compilers. They also lead to weird portability problems when you don't obey all the restrictions put on them by the C standard. For instance, if(setjmp(ick_cjb)!=0) puts("Jumped"); is portable, but if(setjmp(ick_cjb)) puts("Jumped"); is not, despite seeming to mean exactly the same thing. Also, the address of setjmp can't be taken. Semantically, setjmp/longjmp lets you do the same crazy things like goto, like jump into the middle of a loop, except in this case the loop can be in a different function, or even in a different file. unravel.c has no qualms about jumping straight into the middle of an if statement in a degenerated C program, even if said degenerated C program didn't exist when libickmt.a was compiled. */ /* LINTLIBRARY */ #include "config.h" #include #include #include #include #include #define MULTITHREAD 1 #include "sizes.h" #include "abcess.h" #include "ick_lose.h" int gonebackto; /* Is the choicepoint reached by GOING BACK? */ static int choicing = 0; /* Is a multithread function being used to do backtracking processing? */ jmp_buf btjb; /* The backtracking jmp_buf */ /* About the annotation 'dependent': topchoice is really 'owned', but the owner keeps on changing. So Splint gets less confused if we simply never tell it who the owner is. */ /*@null@*/ /*@dependent@*/ static ickthread* topchoice; /* Top of the choicepoint stack */ extern int ick_lineno; /* Keep track of error-message lines */ extern int ick_printflow; /* from arrgghh.c; a debug option */ int weaving=0; /* Weave newly created threads? */ /* Printflow debugging output */ static void fluputs(const char* s) { fprintf(stderr,"%s",s); (void) fflush(stderr); } /********************************************************************** * * This functions deal with choicepoints, which are implemented as * ickthread objects. choicepoint creates a choicepoint or marks a * choicepoint as stale; choiceahead eliminates a choicepoint; * choiceback eliminates a stale choicepoint or returns to a fresh * choicepoint. * *********************************************************************/ void choicepoint(void) { ickthread* oldprev, *oldtc; int oldweave; if(gonebackto) { /* Create a stale choicepoint */ if(ick_printflow) fluputs("(back)"); oldtc = topchoice; /* Suppress the onlytrans warning because we're allocating a member of a linked list, which confuses Splint no matter what the list is flagged as (because malloc returns 'only' data, but yet that data has to be pointed to by other 'only' data in the same list). */ /*@-onlytrans@*/ topchoice = (ickthread*) malloc(sizeof(ickthread)); /*@=onlytrans@*/ if(!topchoice) ick_lose(IE991, ick_lineno, (const char*) NULL); topchoice->choicepoint = oldtc; topchoice->stale = 1; topchoice->refcount = 1; /* At the moment, this is the only thread looking at this choicepoint */ topchoice->dsi=topchoice; topchoice->usesthis=0; /* topchoice needn't be completely defined if it's stale */ /*@-compdef@*/ return; /*@=compdef@*/ } else { /* Create a new choicepoint */ if(ick_printflow) fluputs("(maybe)"); oldprev = ickmt_prev; choicing = 1; oldweave = weaving; weaving = 0; (void) multicome1(ick_lineno,btjb); /* Duplicate data */ weaving = oldweave; choicing = 0; oldprev->ick_next = ickmt_cur; ickmt_prev->choicepoint = topchoice; topchoice = ickmt_prev; ickmt_prev = oldprev; topchoice->stale = 0; topchoice->refcount = 1; /* So in other words, we've duplicated the current execution environment, except for the choicepoint stack, changed the duplicate from a thread into a choicepoint, and pushed it on top of the choicepoint stack. Its pc is the point in the degenerated program where choicepoint was called. */ } } void choiceahead(void) { ickthread* tempthread; jmp_buf fakepc; if(!topchoice) ick_lose(IE404, ick_lineno, (const char*) NULL); /* That's what IE404's for */ /* GO AHEAD with multithreading requires care. The choicepoint should only be removed from this thread. topchoice = topchoice->ick_next almost works, but is a memory leak. So most of this is garbage-collection. */ /* If other threads are using the choicepoint, don't free it. */ if(topchoice->refcount > 1) { if(ick_printflow) fluputs("(refahead)"); topchoice->refcount--; topchoice = topchoice->choicepoint; return; } /* The top choicepoint is not being used by other threads; free it. */ /* Freeing a stale choicepoint (which contains no data) is easy. */ if(topchoice->stale) { if(ick_printflow) fluputs("(destale)"); tempthread = topchoice; topchoice = topchoice->choicepoint; /*@-dependenttrans@*/ /* because it's really owned, not dependent */ free(tempthread); /*@=dependenttrans@*/ return; } if(ick_printflow) fluputs("(ahead)"); /* This code works by converting topchoice back to a thread and placing it just before the current thread, and then killing it. First, the data from this thread, apart from the choicepoint stack, must be saved. */ choicing = 1; if(setjmp(fakepc) == 0) { memcpy((void*)ickmt_cur->pc,(const void*)fakepc,sizeof(jmp_buf)); nextthread(fakepc, -1, 5); } choicing = 0; /* That's saved the current thread's data. Now to convert topchoice to a thread. */ tempthread = topchoice->choicepoint; ickmt_prev->ick_next = topchoice; topchoice->ick_next = ickmt_cur; ickmt_cur = topchoice; topchoice = tempthread; /* Let's load the backtracking data... */ choicing = 1; if(setjmp(fakepc) == 0) { memcpy((void *)ickmt_cur->pc,(const void *)fakepc,sizeof(jmp_buf)); nextthread(fakepc, -1, 6); } /* only to destroy it! Mwahahahahah! */ if(setjmp(fakepc) == 0) { memcpy((void *)ickmt_cur->ick_next->pc,(const void *)fakepc,sizeof(jmp_buf)); killthread(); } choicing = 0; /* So we've reloaded the original current thread, the original previous thread is still correct, topchoice has become topchoice->choicepoint, and the original topchoice has disappeared. Mission accomplished. */ } void choiceback(void) { if(!topchoice) ick_lose(IE404, ick_lineno, (const char *) NULL); if(topchoice->stale) { if(ick_printflow) fluputs("(back=)"); choiceahead(); return; } /* That's two simple cases out of the way (at least once choiceahead's been implemented). What we need to do to backtrack is to change topchoice to a thread after the current thread (rather than before as in the previous two functions), and then kill the current thread. (It amuses me that destroying a choicepoint, as in choiceahead(), is more complicated than either visiting a choicepoint or creating a choicepoint. That's how much work it can take to avoid a memory leak.) In this case, choiceback won't return in the normal fashion. */ if(topchoice->refcount > 1) { /* The Threaded INTERCAL standard states that if other threads are using the choicepoint, a GO BACK should cause the thread it's in to be killed. (Of course, if it's stale, it should just have been removed.)*/ if(ick_printflow) fluputs("(desplit)"); killthread(); return; } topchoice->ick_next = ickmt_cur->ick_next; ickmt_cur->ick_next = topchoice; topchoice = topchoice->choicepoint; if(ickmt_cur==ickmt_prev) ickmt_prev = ickmt_cur->ick_next; choicing = 2; /* Tells killthread to set it back to 0 */ killthread(); } /********************************************************************** * * This function is called when two COME FROMs reference the same * line at runtime. multicome1 is used in a multithread * program; it forks the program. For ick_multicome0, see cesspool.c. * *********************************************************************/ int multicome1(int errlineno, jmp_buf pc) { /* Make a new thread just before the current one. Fake a PC in the current thread within this function, change to the new thread, then call nextthread. The upshot of all this is that all this thread's data is stored in the new thread's state. Then, we have to copy all this thread's current data to new locations. */ ickthread* newthread; jmp_buf fakepc; ick_stashbox *isb, *isb2, *isbprev; void* tvp; ick_array* a; int prod, i, j; newthread = malloc(sizeof(ickthread)); if(!newthread) ick_lose(IE991, errlineno, (const char *) NULL); ickmt_prev->ick_next = newthread; newthread->ick_next = ickmt_cur; ickmt_cur = newthread; newthread->dsi=newthread; newthread->usesthis=0; if(ick_printflow && !choicing) fluputs("(fork)"); if(setjmp(fakepc) == 0) { memcpy((void *)newthread->ick_next->pc,(const void *)fakepc,sizeof(jmp_buf)); nextthread(pc, -1, 1); } /* So on the previous line: Save the value of pc as the program counter of the new thread, and give a fake value for the program value of the current thread (so it returns here, not anywhere in the degenerated program). All that remains is to duplicate all the data stored through pointers in the 'old' thread (nextthread has changed ickmt_cur to point at the 'old' thread). The original memory pointed to by these pointers is in use storing the values in the 'new' thread, so the 'old' thread needs new copies that it can modify independently. */ if(!weaving) { /* duplicate variables, forget indicators */ i = onespotcount; tvp = ick_onespots; ick_onespots = malloc(i * sizeof *ick_onespots); if(!ick_onespots) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(ick_onespots, tvp, i * sizeof *ick_onespots); if(ick_oo_onespots) { tvp = ick_oo_onespots; ick_oo_onespots = malloc(i * sizeof *ick_oo_onespots); if(!ick_oo_onespots) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(ick_oo_onespots, tvp, i * sizeof *ick_oo_onespots); } i = twospotcount; tvp = ick_twospots; ick_twospots = malloc(i * sizeof *ick_twospots); if(!ick_twospots) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(ick_twospots, tvp, i * sizeof *ick_twospots); if(ick_oo_twospots) { tvp = ick_oo_twospots; ick_oo_twospots = malloc(i * sizeof *ick_oo_twospots); if(!ick_oo_twospots) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(ick_oo_twospots, tvp, i * sizeof *ick_oo_twospots); } i = tailcount; tvp = ick_tails; ick_tails = malloc(i * sizeof *ick_tails); if(!ick_tails) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(ick_tails, tvp, i * sizeof *ick_tails); i = hybridcount; tvp = ick_hybrids; ick_hybrids = malloc(i * sizeof *ick_hybrids); if(!ick_hybrids) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(ick_hybrids, tvp, i * sizeof *ick_hybrids); i = onespotcount; tvp = ick_oneforget; ick_oneforget = malloc(i * sizeof *ick_oneforget); if(!ick_oneforget) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(ick_oneforget, tvp, i * sizeof *ick_oneforget); i = twospotcount; tvp = ick_twoforget; ick_twoforget = malloc(i * sizeof *ick_twoforget); if(!ick_twoforget) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(ick_twoforget, tvp, i * sizeof *ick_twoforget); i = tailcount; tvp = ick_tailforget; ick_tailforget = malloc(i * sizeof *ick_tailforget); if(!ick_tailforget) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(ick_tailforget, tvp, i * sizeof *ick_tailforget); i = hybridcount; tvp = ick_hyforget; ick_hyforget = malloc(i * sizeof *ick_hyforget); if(!ick_hyforget) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(ick_hyforget, tvp, i * sizeof *ick_hyforget); /* duplicate data stored in arrays */ j = tailcount; tvp = NULL; while(j--) { a = ick_tails+j; /* &(ick_tails[j]) */ if(!a->rank||!a->dims) continue; /* don't duplicate a deallocated ick_array */ tvp = a->dims; /* Much of this code is paraphrased from the ick_stashbox-copying code below, which was in turn paraphrased from a section in cesspool.c I didn't write. So any errors in this code are probably mine, but the algorithm isn't. */ a->dims = malloc(a->rank * sizeof *(a->dims)); if(a->dims == NULL) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(a->dims, tvp, a->rank * sizeof *(a->dims)); prod = (int)!!a->rank; i = (int)a->rank; while(i--) prod *= a->dims[i]; /*@-mustfreeonly@*/ /* how on earth did a->dims become only? */ tvp = a->data.tail; /*@=mustfreeonly@*/ a->data.tail = malloc(prod * sizeof(ick_type16)); if(!a->data.tail) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(a->data.tail, tvp, prod * sizeof(ick_type16)); /*@-mustfreeonly@*/ /* likewise. This isn't only, honest! */ tvp = NULL; /*@=mustfreeonly@*/ } j = hybridcount; while(j--) { a = ick_hybrids+j; /* &(ick_hybrids[j]) */ if(!a->rank||!a->dims) continue; /* don't duplicate a deallocated ick_array */ tvp = a->dims; /* Much of this code is paraphrased from the ick_stashbox-copying code below, which was in turn paraphrased from a section in cesspool.c I didn't write. So any errors in this code are probably mine, but the algorithm isn't. */ a->dims = malloc(a->rank * sizeof(*(a->dims))); if(!a->dims) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(a->dims, tvp, a->rank * sizeof(*(a->dims))); prod = (int)!!a->rank; i = (int)a->rank; while(i--) prod *= a->dims[i]; /*@-mustfreeonly@*/ tvp = a->data.hybrid; /*@=mustfreeonly@*/ a->data.hybrid = malloc(prod * sizeof(ick_type32)); if(!a->data.hybrid) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(a->data.hybrid, tvp, prod * sizeof(ick_type32)); /*@-mustfreeonly@*/ tvp=NULL; /*@=mustfreeonly@*/ } /* duplicate ick_stashbox */ isb2 = ick_first; isbprev = (ick_stashbox*)NULL; while(isb2) { isb = (ick_stashbox*)malloc(sizeof(ick_stashbox)); if(!isb) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(isb,isb2,sizeof(ick_stashbox)); if(isbprev) isbprev->ick_next = isb; isbprev = isb; if(isb2==ick_first) ick_first = isb; /* change ick_first only the ick_first time round */ if(isb->type == ick_ONESPOT || isb->type == ick_TWOSPOT) { /* all copying already done */ isb2 = isb->ick_next; continue; } /* Copy the stashed ick_array. Much of this code is paraphrased from some code in cesspool.c. In fact, it's the same, with a few idioms added and variable names changed. So, although it's in this file, I can't take the credit for it. */ isb->save.a = (ick_array*)malloc(sizeof(ick_array)); if(!isb->save.a) ick_lose(IE991, errlineno, (const char *) NULL); assert(isb2 != NULL); /* we already said that in the while condition, so it's surprising that Splint needs this hint */ isb->save.a->rank = isb2->save.a->rank; isb->save.a->dims = malloc(isb2->save.a->rank * sizeof(*(isb2->save.a->dims))); if(!isb->save.a->dims) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(isb->save.a->dims, isb2->save.a->dims, isb2->save.a->rank * sizeof(*(isb2->save.a->dims))); prod = (int)!!isb2->save.a->rank; /* I use this idiom often enough in the code produced by my optimizer that I may as well use it here. */ i = (int)isb2->save.a->rank; while(i--) prod *= isb2->save.a->dims[i]; if(isb2->type == ick_TAIL) { isb->save.a->data.tail = (ick_type16*)malloc(prod * sizeof(ick_type16)); if(!isb->save.a->data.tail) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(isb->save.a->data.tail, isb2->save.a->data.tail, prod * sizeof(ick_type16)); } else { isb->save.a->data.hybrid = (ick_type32*)malloc(prod * sizeof(ick_type32)); if(!isb->save.a->data.hybrid) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(isb->save.a->data.hybrid, isb2->save.a->data.hybrid, prod * sizeof(ick_type32)); } isb2 = isb->ick_next; } } else /* we are weaving, reference the old current thread */ { ickthread* tempthread; if(ick_printflow) fluputs("(weave)"); /* Sanity check to make sure that the threads are arranged correctly */ if(newthread->ick_next!=ickmt_cur) ick_lose(IE778, errlineno, (const char *) NULL); tempthread=newthread->ick_next; /* the old current thread */ while(tempthread->usesthis) tempthread=tempthread->usesthis; newthread->dsi=tempthread->dsi; tempthread->usesthis=newthread; } /* duplicate NEXT stack */ tvp = ick_next; ick_next = malloc(ick_MAXNEXT * sizeof *ick_next); if(!ick_next) ick_lose(IE991, errlineno, (const char *) NULL); memcpy(ick_next, tvp, ick_MAXNEXT * sizeof *ick_next); /* allow for multithreading with choicepoints on the stack */ if(!choicing && topchoice != NULL) { ickthread* icktp = topchoice; while(icktp) { icktp->refcount++; icktp = icktp->choicepoint; /* ick_next choicepoint on the stack */ } /* The old thread's and new thread's choicepoint stack share memory. This is pretty much necessary to handle backtracking past a fork correctly. */ } /* The nullstate annotation is because Splint doesn't notice that all the mallocs are guarded by lines that error out permanently if they fail. The mustfreefresh annotation is because Splint doesn't realise that I've stored newthread in a pointer buried in the linked list of threads, and so Splint assumes that it's memory-leaking. */ /*@-nullstate@*/ /*@-mustfreefresh@*/ return 1; /* Tell the degenerated program to look for yet another COME FROM */ /*@=nullstate@*/ /*@=mustfreefresh@*/ } /********************************************************************** * * These functions do the multithreading, using setjmp and longjmp * to save the program counter. ickmtinit sets up the ick_first * thread, and nextthread changes to the ick_next thread in the * sequence. (Note that nextthread rarely actually returns). The * code makes each command atomic, so that ONCE and AGAIN appear * to the user to be atomic operations. * *********************************************************************/ /*@partial@*/ /*@dependent@*/ ickthread* ickmt_cur; /* define ickmt_cur */ /*@partial@*/ /*@dependent@*/ ickthread* ickmt_prev; /* define ickmt_prev */ void ickmtinit(void) { /* Splint linked list problems again; the list is marked as 'dependent', which is correct for everything except adding and removing items in the list. (All annotations are incorrect in some respects.) */ /*@-onlytrans@*/ ickmt_cur = malloc(sizeof(ickthread)); /*@=onlytrans@*/ if(!ickmt_cur) ick_lose(IE991, 1, (const char *) NULL); ickmt_prev = ickmt_cur; ickmt_cur->ick_next = ickmt_cur; topchoice = (ickthread*) NULL; /* No choicepoints */ ickmt_cur->dsi=ickmt_cur; ickmt_cur->usesthis=0; } /* Destroys the current thread, and switches to the ick_next thread. If there are no threads left, terminates the program using exit(0). */ void killthread(void) { static jmp_buf dummy; ick_stashbox* isb, *isbi; int i; if(ick_printflow&&!choicing) fluputs("(kill)"); if(!choicing) while(topchoice) choiceahead(); /* The above line will mark each of the choicepoints as no longer being used by this thread, and free them if neccesary. This has to be done ick_first while this thread's pointers are still valid due to the way that choiceahead works. */ /* If this thread uses another, let the other know about the change */ if(ickmt_cur->dsi!=ickmt_cur) { ickthread* temp=ickmt_cur->dsi; if(ick_printflow) fluputs("(deweave)"); while(!temp||temp->usesthis!=ickmt_cur) { if(!temp) ick_lose(IE778, -1, (const char *) NULL); temp=temp->usesthis; } temp->usesthis=ickmt_cur->usesthis; } /* If this thread is holding data for others, move it somewhere safe */ if(ickmt_cur->usesthis != NULL && ickmt_cur->usesthis->dsi==ickmt_cur) { ickthread* newuses=ickmt_cur->usesthis; ickthread* temp=ickmt_cur->usesthis; if(ick_printflow) fluputs("(shift)"); while(temp) { temp->dsi=newuses; temp=temp->usesthis; } ickmt_cur->dsi=newuses; /* so the data will be transferred later */ } if(ickmt_cur->dsi==ickmt_cur) { /* We aren't storing data for another thread, and we have data of our own, or dsi would point somewhere else (either naturally or because it was changed higher up). */ if(ick_printflow) fluputs("(free)"); /* Deallocate the current thread's data */ i=tailcount; while(i--) { /* free tail data */ if(!ick_tails[i].rank||!ick_tails[i].dims) continue; /* already free */ free(ick_tails[i].dims); free(ick_tails[i].data.tail); } i=hybridcount; while(i--) { /* free hybrid data */ if(!ick_hybrids[i].rank||!ick_hybrids[i].dims) continue; /* already free */ free(ick_hybrids[i].dims); free(ick_hybrids[i].data.hybrid); } /* unqualifiedtrans because although they aren't always only, they're only at the moment; compdestroy because we have just deallocated tail and hybrid data */ /*@-unqualifiedtrans@*/ /*@-compdestroy@*/ free(ick_onespots); free(ick_twospots); free(ick_tails); free(ick_hybrids); free(ick_oneforget); free(ick_twoforget); free(ick_tailforget); free(ick_hyforget); if(ick_oo_onespots) free(ick_oo_onespots); if(ick_oo_twospots) free(ick_oo_twospots); /*@=unqualifiedtrans@*/ /*@=compdestroy@*/ isbi = ick_first; while(isbi) /* Free ick_stash */ { isb=isbi->ick_next; if(isbi->type == ick_TAIL || isbi->type == ick_HYBRID) { free(isbi->save.a->dims); if(isbi->type == ick_TAIL) free(isbi->save.a->data.tail); else free(isbi->save.a->data.hybrid); } free(isbi); isbi=isb; } } else { /* We still need to save our variables for the benefit of woven threads. */ /* save variables */ ickmt_cur->dsi->varforget[0] = ick_onespots; ickmt_cur->dsi->varforget[1] = ick_twospots; ickmt_cur->dsi->varforget[2] = ick_tails; ickmt_cur->dsi->varforget[3] = ick_hybrids; ickmt_cur->dsi->varforget[4] = ick_oneforget; ickmt_cur->dsi->varforget[5] = ick_twoforget; ickmt_cur->dsi->varforget[6] = ick_tailforget; ickmt_cur->dsi->varforget[7] = ick_hyforget; ickmt_cur->dsi->varforget[8] = ick_oo_onespots; ickmt_cur->dsi->varforget[9] = ick_oo_twospots; /* save ick_stashbox */ /*@-unqualifiedtrans@*/ /* the linked list problem again */ ickmt_cur->dsi->sb = ick_first; /*@=unqualifiedtrans@*/ /*@-branchstate@*/ /* it's reference-counted */ } /*@=branchstate@*/ /*@-unqualifiedtrans@*/ /* it is only at this point */ free(ick_next); /* Free NEXT stack */ /*@=unqualifiedtrans@*/ ickmt_prev->ick_next = ickmt_cur->ick_next; if(ickmt_cur->ick_next == ickmt_cur) { /*@-dependenttrans@*/ /* because it isn't really dependent */ free(ickmt_cur); /*@=dependenttrans@*/ exit(0); } else { /* We need to run about half of nextthread. So we pass in a 2 for flags and tell it to skip the ick_first half. */ /*@-dependenttrans@*/ /* because it isn't really dependent */ free(ickmt_cur); /*@=dependenttrans@*/ ickmt_cur = ickmt_prev; nextthread(dummy, -1, 2); /* dummy is not used by nextthread */ ick_lose(IE778, -1, (const char *) NULL); /* nextthread does not return */ } } /* This function does not return in the normal fashion, but by a nonlocal goto to a mysterious location, possibly in multicome1 but possibly in the degenerated code. From the point of view of libickmt.a, we're going to a piece of code that doesn't even exist yet! The general ugliness of INTERCAL multithreading pulls out all the stops when it comes to using unusual and confusing C control structures. It is important to remember that longjmp clobbers all auto variables that have changed since the corresponding setjmp. */ /* In this Threaded INTERCAL implementation, data is saved in a linked ring of threads. A thread runs for a command, then all the data pointers are changed, saving the old ones. This is an improvement on an earlier attempt of mine in which the values themselves were copied, but is still less efficient than Malcom Ryan's method (which didn't involve copying things about except when forking). However, I justify this by saying that it leaves as much existing code as possible untouched, which is helpful for single- thread compatibility, modifying the code in feh.c without an understanding of multithread issues, and because I'm lazy. It also makes the rest of the program shorter. */ void nextthread(jmp_buf pc, int errlineno, int flags) { /* flags | 1 means save this thread. flags | 2 means load the ick_next thread. flags | 4 means don't change thread. */ if(errlineno > -1 && ickmt_cur->ick_next == ickmt_cur && !choicing) longjmp(pc,1); /* If we only have 1 thread, just continue with it. Otherwise: */ if(!(flags&1)) goto advancethread; /* OK, so I've spaghettified this procedure slightly by using goto instead of if. But I was so deep into figuring out setjmp/longjmp, a goto seemed crystal-clear by comparison. */ /* save variables */ ickmt_cur->dsi->varforget[0] = ick_onespots; ickmt_cur->dsi->varforget[1] = ick_twospots; ickmt_cur->dsi->varforget[2] = ick_tails; ickmt_cur->dsi->varforget[3] = ick_hybrids; ickmt_cur->dsi->varforget[4] = ick_oneforget; ickmt_cur->dsi->varforget[5] = ick_twoforget; ickmt_cur->dsi->varforget[6] = ick_tailforget; ickmt_cur->dsi->varforget[7] = ick_hyforget; ickmt_cur->dsi->varforget[8] = ick_oo_onespots; ickmt_cur->dsi->varforget[9] = ick_oo_twospots; /* save NEXT stack */ /*@-unqualifiedtrans@*/ /* because nextstack isn't only really */ ickmt_cur->nextstack = ick_next; /*@=unqualifiedtrans@*/ ickmt_cur->nextpointer = ick_nextindex; /* save ick_stashbox */ /*@-unqualifiedtrans@*/ /* ditto */ ickmt_cur->dsi->sb = ick_first; /*@=unqualifiedtrans@*/ /* save choicepoints */ if(!choicing) ickmt_cur->choicepoint = topchoice; /* save comefrom information */ memcpy((void*)(ickmt_cur->ick_cjb), (const void*)ick_cjb, sizeof(jmp_buf)); ickmt_cur->ick_ccfc = ick_ccfc; ickmt_cur->ick_skipto = ick_skipto; /* save program counter */ memcpy((void*)(ickmt_cur->pc), (const void*)pc, sizeof(jmp_buf)); /* And another thing about setjmp/longjmp. A jmp_buf acts like a structure that passes itself around by reference. However, it cannot be assigned, although just about everything else in C can be, although it can be copied with memcpy (what I'm doing in the line above - remember it passes itself around by reference). Generally speaking, it's some sort of ick_array, even though some implementors use a 1-element ick_array. The exact representation of jmp_buf is one of the most implementation-dependent things in C (I've seen both a 1-element ick_array of structure and an int[12].) */ advancethread: /* change thread */ if(!(flags&4)) { ickmt_prev = ickmt_cur; ickmt_cur = ickmt_cur->ick_next; } if(!(flags&2)) goto returnjmp; /* load variables */ ick_onespots = ickmt_cur->dsi->varforget[0]; ick_twospots = ickmt_cur->dsi->varforget[1]; ick_tails = ickmt_cur->dsi->varforget[2]; ick_hybrids = ickmt_cur->dsi->varforget[3]; ick_oneforget = ickmt_cur->dsi->varforget[4]; ick_twoforget = ickmt_cur->dsi->varforget[5]; ick_tailforget = ickmt_cur->dsi->varforget[6]; ick_hyforget = ickmt_cur->dsi->varforget[7]; ick_oo_onespots = ickmt_cur->dsi->varforget[8]; ick_oo_twospots = ickmt_cur->dsi->varforget[9]; /* load NEXT stack */ /*@-onlytrans@*/ /* the nextstack shouldn't be only */ ick_next = ickmt_cur->nextstack; /*@=onlytrans@*/ ick_nextindex = ickmt_cur->nextpointer; /* load choicepoints */ if(!choicing) topchoice = ickmt_cur->choicepoint; /* load ick_stashbox */ /*@-onlytrans@*/ /* ditto */ ick_first = ickmt_cur->dsi->sb; /*@=onlytrans@*/ /* load comefrom information */ memcpy((void*)ick_cjb, (const void*)(ickmt_cur->ick_cjb), sizeof(jmp_buf)); ick_ccfc = ickmt_cur->ick_ccfc; ick_skipto = ickmt_cur->ick_skipto; returnjmp: /* return to the new current thread's program counter */ if(choicing==2) choicing = 0; longjmp(ickmt_cur->pc, 1); } intercal-0.29/src/uncommon.c0000644000175000017500000001452411443403272015715 0ustar brooniebroonie/* * uncommon.c -- functions used by ick, convickt, yuk and compiled programs * LICENSE TERMS Copyright (C) 2007 Alex Smith 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 "uncommon.h" /* Options that might affect this */ bool ick_printfopens=0; /*@dependent@*/ /*@null@*/ FILE* ick_debfopen(/*@observer@*/ const char* fname, /*@observer@*/ const char* mode) { FILE* t; if(ick_printfopens) fprintf(stderr,"Trying to open '%s'...\n",fname); t=fopen(fname,mode); if(ick_printfopens && t != NULL) fprintf(stderr,"Success!\n"); if(ick_printfopens && t == NULL) fprintf(stderr,"Failed!\n"); return t; } /* This function looks for the skeleton and syslib, searching first the path they should be in, then the current directory, then argv[0]'s directory (if one was given). This function avoids possible buffer overflows, instead truncating filenames (and if that manages to find them, I'll be incredibly surprised). It also tries argv[0]/../lib and argv[0]/../include (where they are when running without installing). */ /*@dependent@*/ /*@null@*/ FILE* ick_findandfopen(/*@observer@*/ const char* file, /*@observer@*/ const char* guessdir, /*@observer@*/ const char* mode, /*@observer@*/ const char* argv0) { static char buf2[BUFSIZ]; /*@observer@*/ static const char *fileiter; size_t i = 0, j; FILE* ret; while(guessdir && *guessdir != '\0' && i= size) ick_lose(IE553, 0, (const char*)NULL); #endif va_end(ap); return retval; } intercal-0.29/src/convickt.c0000644000175000017500000001101211443404360015666 0ustar brooniebroonie/***************************************************************************** NAME convickt.c -- translate between various INTERCAL formats LICENSE TERMS Copyright (C) 2007 Alex Smith 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 extern int ick_clc_cset_convert(const char* in, /*@partial@*/ char* out, const char* incset, const char* outcset, int padstyle, size_t outsize, /*@null@*/ FILE* errsto); /* For communication with clc_cset.c */ /*@observer@*/ char* ick_globalargv0; /*@-redef@*/ /* it's never the case that both definitions are used at once */ /*@observer@*/ /*@dependent@*/ const char* ick_datadir; /*@=redef@*/ /* We want to read the latest versions of the character sets from disk. */ /*@null@*/ const char* ick_clc_cset_atari=0; /*@null@*/ const char* ick_clc_cset_baudot=0; /*@null@*/ const char* ick_clc_cset_ebcdic=0; /*@null@*/ const char* ick_clc_cset_latin1=0; /* In case we don't have vsnprintf. */ void /*@noreturn@*/ ick_lose(const char *m, int n, /*@null@*/ const char *s) { (void) m; (void) n; (void) s; abort(); } /*@-redef@*/ /* because only one main is used at a time */ int main(int argc, char** argv) /*@=redef@*/ { size_t allocsize=100; char* in; char* out; size_t i=0; int ti; int c; int padding=-1; ick_globalargv0=argv[0]; srand((unsigned)time(NULL)); if(argc<3||argc>5) { fprintf(stderr,"Usage: convickt informat outformat [padding [arrayname]]\n"); fprintf(stderr,"Available formats are:\n"); fprintf(stderr,"\tPrinceton: latin1, baudot, ebcdic\n"); fprintf(stderr,"\tAtari: atari (7-bit ASCII)\n"); fprintf(stderr,"Possible values for padding are:\n"); fprintf(stderr,"\tprintable: try to leave the output in char range " "32-126\n"); fprintf(stderr,"\tzero: leave the output with 0s in the high bits\n"); fprintf(stderr,"\trandom: pad with random data\n"); fprintf(stderr,"Padding only has an effect on character sets with less\n"); fprintf(stderr,"than 8 bits used per bytes; default is 'printable'.\n"); fprintf(stderr,"If arrayname is given, which must be a legal name for\n"); fprintf(stderr,"a tail array, the output will instead be a portable\n"); fprintf(stderr,"INTERCAL program that stores the required byte pattern\n"); fprintf(stderr,"in that array.\n"); return 0; } if(argc>=4&&!strcmp(argv[3],"printable")) padding=1; if(argc>=4&&!strcmp(argv[3],"zero")) padding=0; if(argc>=4&&!strcmp(argv[3],"random")) padding=2; if(argc>=4&&padding==-1) { fprintf(stderr,"Error: padding value not recognized.\n"); return 1; } if(!(ick_datadir=getenv("ICKDATADIR"))) ick_datadir=ICKDATADIR; in=malloc(allocsize); if(!in) {perror("Error: Memory allocation failure"); return 0;} while((c=getchar())!=EOF) { in[i++]=(char)c; if(i+1>=allocsize) { char* temp=in; allocsize*=2; in=realloc(in,allocsize); if(!in) { perror("Error: Memory allocation failure"); /* Annotation, because in hasn't been freed here; that's what the error return from realloc means. */ /*@-usereleased@*/ if(temp) free(temp); /*@=usereleased@*/ return 0; } } } in[i]='\0'; out=malloc(allocsize*6+6); if(!out) { perror("Error: Memory allocation failure"); free(in); return 0; } ti=ick_clc_cset_convert(in,out,argv[1],argv[2],padding,allocsize*6+6,stderr); if(ti>=0&&argc<5) (void) fwrite(out,1,(size_t)ti,stdout); else if(ti>=0&&argc==5) { int pleasedelay=2; printf("\tDO %s <- #%d\n",argv[4],ti); while(ti--) { printf("\t"); if(!--pleasedelay) {printf("PLEASE "); pleasedelay=4;} printf("DO %s SUB #%d <- #%d\n",argv[4],ti+1,(int)(out[ti])); } } free(in); free(out); return ti<0; } intercal-0.29/src/cooptsh.in0000644000175000017500000000347411443404177015734 0ustar brooniebroonie#! /bin/sh ########################################################################### # # Name # coopt.sh -- an inefficient optimizer that can produce very efficient # code # # DESCRIPTION # This optimizer is only run on noninteractive code that takes no # output. (It's designed to run on executables produced by INTERCAL # code, but will run on other executables that support the +mystery # option). It optimizes the file by replacing it by one that simply # produces the required output! Therefore, it creates fast but # inefficient code. If the file to be optimized hits an error or # is terminated by +mystery, then no changes are made. # # LICENSE TERMS # Copyright (C) 2006 Alex Smith # # 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. # ########################################################################### rm -f icktemp.out >/dev/null 2>/dev/null if `readlink -f $1@EXEEXT@` +mystery >icktemp.out 2>/dev/null ; then : ; else echo Execution of $1@EXEEXT@ failed. rm -f icktemp.out ; exit 0 ; fi rm $1@EXEEXT@ echo '#! /bin/sh tail -n+3 $0; exit 0' | cat - icktemp.out > $1@EXEEXT@ chmod +x $1@EXEEXT@ rm -f icktemp.out exit 0 intercal-0.29/doc/0000755000175000017500000000000011545350335013672 5ustar brooniebroonieintercal-0.29/doc/convickt.10000644000175000017500000000543611435477314015611 0ustar brooniebroonie.TH CONVICKT 1 .\" NAME should be all caps, SECTION should be 1-8, maybe w/ subsection .\" other parms are allowed: see man(7), man(1) .\" .\" Created by Alex Smith; licensed under GNU GPL v2 or later. .SH NAME convickt \- convert INTERCAL files between formats .SH SYNOPSIS .B convickt .I "incharset outcharset [paddingrule [arrayname]]" .SH "DESCRIPTION" This manual page describes the .BR convickt command. Fuller documentation is available via the command .B info convickt . .PP .B convickt converts INTERCAL programs from one character set to another; it takes input from standard input and sends its output to standard output. .SH OPTIONS For .I incharset and .I outcharset .TP .B atari Interpret the input as being ASCII-7 Atari syntax INTERCAL, as is used by the Atari INTERCAL-72 compiler, J-INTERCAL, and C-INTERCAL default syntax, or output in that syntax. .TP .B baudot Interpret the input as being in CLC-INTERCAL's extended Baudot syntax, or output in that syntax. .TP .B ebcdic Interpret the input as being in the CLC-INTERCAL dialect of EBCDIC, or output in that syntax. .TP .B latin1 Interpret the input as being Latin-1 Princeton syntax INTERCAL, as is used by default by CLC-INTERCAL and also readable by C-INTERCAL with the .B \-X switch, or output in that syntax. .PP For .I paddingrule .TP .B zero Pad the irrelevant bits in ASCII-7 and Baudot output with zeros. .TP .B printable Set the values of the irrelevant bits in ASCII-7 and Baudot output to try to cause the output to stay within character range 32-126. This option is the default. (Note that .I paddingrule is irrelevant for 8-bit character sets like Latin-1 and EBCDIC). .TP .B random Pad the irrelevant bits in ASCII-7 and Baudot output with random data, except that outputing an all-bits-zero octet is avoided. .SH CAVEATS Not all conversions are possible, due to the character sets having different characters available. In most cases, an unconvertible or invalid character will be converted to a 0 (padded appropriately); the exception is that if a tab cannot be converted, it will instead be converted to a single space (so that INTERCAL programs still run if converted to Baudot). Using .B atari as an input or output character set will literally convert characters which differ between Atari and Princeton syntax without checking to see whether they are being used as operators or not. .PP If .I arrayname is given, then instead of outputting the converted text literally, it will be output as portable (that is, legal in INTERCAL-72, C-INTERCAL, J-INTERCAL and CLC-INTERCAL) INTERCAL that dimensions the tail array given as .I arrayname and assigns each byte of the output to an element of that array; this is mostly useful for producing Baudot text for CLC-INTERCAL-style array IO. .SH AUTHOR .B convickt and this manual page were written by Alex Smith. intercal-0.29/doc/fdl-1-2.txi0000644000175000017500000005103211435477314015470 0ustar brooniebroonie@c The GNU Free Documentation License. @center Version 1.2, November 2002 @c This file is intended to be included within another document, @c hence no sectioning command or @node. @display Copyright @copyright{} 2000,2001,2002 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. @end display @enumerate 0 @item PREAMBLE The purpose of this License is to make a manual, textbook, or other functional and useful document @dfn{free} in the sense of freedom: to assure everyone the effective freedom to copy and redistribute it, with or without modifying it, either commercially or noncommercially. Secondarily, this License preserves for the author and publisher a way to get credit for their work, while not being considered responsible for modifications made by others. This License is a kind of ``copyleft'', which means that derivative works of the document must themselves be free in the same sense. It complements the GNU General Public License, which is a copyleft license designed for free software. We have designed this License in order to use it for manuals for free software, because free software needs free documentation: a free program should come with manuals providing the same freedoms that the software does. But this License is not limited to software manuals; it can be used for any textual work, regardless of subject matter or whether it is published as a printed book. We recommend this License principally for works whose purpose is instruction or reference. @item APPLICABILITY AND DEFINITIONS This License applies to any manual or other work, in any medium, that contains a notice placed by the copyright holder saying it can be distributed under the terms of this License. Such a notice grants a world-wide, royalty-free license, unlimited in duration, to use that work under the conditions stated herein. The ``Document'', below, refers to any such manual or work. Any member of the public is a licensee, and is addressed as ``you''. You accept the license if you copy, modify or distribute the work in a way requiring permission under copyright law. A ``Modified Version'' of the Document means any work containing the Document or a portion of it, either copied verbatim, or with modifications and/or translated into another language. A ``Secondary Section'' is a named appendix or a front-matter section of the Document that deals exclusively with the relationship of the publishers or authors of the Document to the Document's overall subject (or to related matters) and contains nothing that could fall directly within that overall subject. (Thus, if the Document is in part a textbook of mathematics, a Secondary Section may not explain any mathematics.) The relationship could be a matter of historical connection with the subject or with related matters, or of legal, commercial, philosophical, ethical or political position regarding them. The ``Invariant Sections'' are certain Secondary Sections whose titles are designated, as being those of Invariant Sections, in the notice that says that the Document is released under this License. If a section does not fit the above definition of Secondary then it is not allowed to be designated as Invariant. The Document may contain zero Invariant Sections. If the Document does not identify any Invariant Sections then there are none. The ``Cover Texts'' are certain short passages of text that are listed, as Front-Cover Texts or Back-Cover Texts, in the notice that says that the Document is released under this License. A Front-Cover Text may be at most 5 words, and a Back-Cover Text may be at most 25 words. A ``Transparent'' copy of the Document means a machine-readable copy, represented in a format whose specification is available to the general public, that is suitable for revising the document straightforwardly with generic text editors or (for images composed of pixels) generic paint programs or (for drawings) some widely available drawing editor, and that is suitable for input to text formatters or for automatic translation to a variety of formats suitable for input to text formatters. A copy made in an otherwise Transparent file format whose markup, or absence of markup, has been arranged to thwart or discourage subsequent modification by readers is not Transparent. An image format is not Transparent if used for any substantial amount of text. A copy that is not ``Transparent'' is called ``Opaque''. Examples of suitable formats for Transparent copies include plain @sc{ascii} without markup, Texinfo input format, La@TeX{} input format, @acronym{SGML} or @acronym{XML} using a publicly available @acronym{DTD}, and standard-conforming simple @acronym{HTML}, PostScript or @acronym{PDF} designed for human modification. Examples of transparent image formats include @acronym{PNG}, @acronym{XCF} and @acronym{JPG}. Opaque formats include proprietary formats that can be read and edited only by proprietary word processors, @acronym{SGML} or @acronym{XML} for which the @acronym{DTD} and/or processing tools are not generally available, and the machine-generated @acronym{HTML}, PostScript or @acronym{PDF} produced by some word processors for output purposes only. The ``Title Page'' means, for a printed book, the title page itself, plus such following pages as are needed to hold, legibly, the material this License requires to appear in the title page. For works in formats which do not have any title page as such, ``Title Page'' means the text near the most prominent appearance of the work's title, preceding the beginning of the body of the text. A section ``Entitled XYZ'' means a named subunit of the Document whose title either is precisely XYZ or contains XYZ in parentheses following text that translates XYZ in another language. (Here XYZ stands for a specific section name mentioned below, such as ``Acknowledgements'', ``Dedications'', ``Endorsements'', or ``History''.) To ``Preserve the Title'' of such a section when you modify the Document means that it remains a section ``Entitled XYZ'' according to this definition. The Document may include Warranty Disclaimers next to the notice which states that this License applies to the Document. These Warranty Disclaimers are considered to be included by reference in this License, but only as regards disclaiming warranties: any other implication that these Warranty Disclaimers may have is void and has no effect on the meaning of this License. @item VERBATIM COPYING You may copy and distribute the Document in any medium, either commercially or noncommercially, provided that this License, the copyright notices, and the license notice saying this License applies to the Document are reproduced in all copies, and that you add no other conditions whatsoever to those of this License. You may not use technical measures to obstruct or control the reading or further copying of the copies you make or distribute. However, you may accept compensation in exchange for copies. If you distribute a large enough number of copies you must also follow the conditions in section 3. You may also lend copies, under the same conditions stated above, and you may publicly display copies. @item COPYING IN QUANTITY If you publish printed copies (or copies in media that commonly have printed covers) of the Document, numbering more than 100, and the Document's license notice requires Cover Texts, you must enclose the copies in covers that carry, clearly and legibly, all these Cover Texts: Front-Cover Texts on the front cover, and Back-Cover Texts on the back cover. Both covers must also clearly and legibly identify you as the publisher of these copies. The front cover must present the full title with all words of the title equally prominent and visible. You may add other material on the covers in addition. Copying with changes limited to the covers, as long as they preserve the title of the Document and satisfy these conditions, can be treated as verbatim copying in other respects. If the required texts for either cover are too voluminous to fit legibly, you should put the first ones listed (as many as fit reasonably) on the actual cover, and continue the rest onto adjacent pages. If you publish or distribute Opaque copies of the Document numbering more than 100, you must either include a machine-readable Transparent copy along with each Opaque copy, or state in or with each Opaque copy a computer-network location from which the general network-using public has access to download using public-standard network protocols a complete Transparent copy of the Document, free of added material. If you use the latter option, you must take reasonably prudent steps, when you begin distribution of Opaque copies in quantity, to ensure that this Transparent copy will remain thus accessible at the stated location until at least one year after the last time you distribute an Opaque copy (directly or through your agents or retailers) of that edition to the public. It is requested, but not required, that you contact the authors of the Document well before redistributing any large number of copies, to give them a chance to provide you with an updated version of the Document. @item MODIFICATIONS You may copy and distribute a Modified Version of the Document under the conditions of sections 2 and 3 above, provided that you release the Modified Version under precisely this License, with the Modified Version filling the role of the Document, thus licensing distribution and modification of the Modified Version to whoever possesses a copy of it. In addition, you must do these things in the Modified Version: @enumerate A @item Use in the Title Page (and on the covers, if any) a title distinct from that of the Document, and from those of previous versions (which should, if there were any, be listed in the History section of the Document). You may use the same title as a previous version if the original publisher of that version gives permission. @item List on the Title Page, as authors, one or more persons or entities responsible for authorship of the modifications in the Modified Version, together with at least five of the principal authors of the Document (all of its principal authors, if it has fewer than five), unless they release you from this requirement. @item State on the Title page the name of the publisher of the Modified Version, as the publisher. @item Preserve all the copyright notices of the Document. @item Add an appropriate copyright notice for your modifications adjacent to the other copyright notices. @item Include, immediately after the copyright notices, a license notice giving the public permission to use the Modified Version under the terms of this License, in the form shown in the Addendum below. @item Preserve in that license notice the full lists of Invariant Sections and required Cover Texts given in the Document's license notice. @item Include an unaltered copy of this License. @item Preserve the section Entitled ``History'', Preserve its Title, and add to it an item stating at least the title, year, new authors, and publisher of the Modified Version as given on the Title Page. If there is no section Entitled ``History'' in the Document, create one stating the title, year, authors, and publisher of the Document as given on its Title Page, then add an item describing the Modified Version as stated in the previous sentence. @item Preserve the network location, if any, given in the Document for public access to a Transparent copy of the Document, and likewise the network locations given in the Document for previous versions it was based on. These may be placed in the ``History'' section. You may omit a network location for a work that was published at least four years before the Document itself, or if the original publisher of the version it refers to gives permission. @item For any section Entitled ``Acknowledgements'' or ``Dedications'', Preserve the Title of the section, and preserve in the section all the substance and tone of each of the contributor acknowledgements and/or dedications given therein. @item Preserve all the Invariant Sections of the Document, unaltered in their text and in their titles. Section numbers or the equivalent are not considered part of the section titles. @item Delete any section Entitled ``Endorsements''. Such a section may not be included in the Modified Version. @item Do not retitle any existing section to be Entitled ``Endorsements'' or to conflict in title with any Invariant Section. @item Preserve any Warranty Disclaimers. @end enumerate If the Modified Version includes new front-matter sections or appendices that qualify as Secondary Sections and contain no material copied from the Document, you may at your option designate some or all of these sections as invariant. To do this, add their titles to the list of Invariant Sections in the Modified Version's license notice. These titles must be distinct from any other section titles. You may add a section Entitled ``Endorsements'', provided it contains nothing but endorsements of your Modified Version by various parties---for example, statements of peer review or that the text has been approved by an organization as the authoritative definition of a standard. You may add a passage of up to five words as a Front-Cover Text, and a passage of up to 25 words as a Back-Cover Text, to the end of the list of Cover Texts in the Modified Version. Only one passage of Front-Cover Text and one of Back-Cover Text may be added by (or through arrangements made by) any one entity. If the Document already includes a cover text for the same cover, previously added by you or by arrangement made by the same entity you are acting on behalf of, you may not add another; but you may replace the old one, on explicit permission from the previous publisher that added the old one. The author(s) and publisher(s) of the Document do not by this License give permission to use their names for publicity for or to assert or imply endorsement of any Modified Version. @item COMBINING DOCUMENTS You may combine the Document with other documents released under this License, under the terms defined in section 4 above for modified versions, provided that you include in the combination all of the Invariant Sections of all of the original documents, unmodified, and list them all as Invariant Sections of your combined work in its license notice, and that you preserve all their Warranty Disclaimers. The combined work need only contain one copy of this License, and multiple identical Invariant Sections may be replaced with a single copy. If there are multiple Invariant Sections with the same name but different contents, make the title of each such section unique by adding at the end of it, in parentheses, the name of the original author or publisher of that section if known, or else a unique number. Make the same adjustment to the section titles in the list of Invariant Sections in the license notice of the combined work. In the combination, you must combine any sections Entitled ``History'' in the various original documents, forming one section Entitled ``History''; likewise combine any sections Entitled ``Acknowledgements'', and any sections Entitled ``Dedications''. You must delete all sections Entitled ``Endorsements.'' @item COLLECTIONS OF DOCUMENTS You may make a collection consisting of the Document and other documents released under this License, and replace the individual copies of this License in the various documents with a single copy that is included in the collection, provided that you follow the rules of this License for verbatim copying of each of the documents in all other respects. You may extract a single document from such a collection, and distribute it individually under this License, provided you insert a copy of this License into the extracted document, and follow this License in all other respects regarding verbatim copying of that document. @item AGGREGATION WITH INDEPENDENT WORKS A compilation of the Document or its derivatives with other separate and independent documents or works, in or on a volume of a storage or distribution medium, is called an ``aggregate'' if the copyright resulting from the compilation is not used to limit the legal rights of the compilation's users beyond what the individual works permit. When the Document is included in an aggregate, this License does not apply to the other works in the aggregate which are not themselves derivative works of the Document. If the Cover Text requirement of section 3 is applicable to these copies of the Document, then if the Document is less than one half of the entire aggregate, the Document's Cover Texts may be placed on covers that bracket the Document within the aggregate, or the electronic equivalent of covers if the Document is in electronic form. Otherwise they must appear on printed covers that bracket the whole aggregate. @item TRANSLATION Translation is considered a kind of modification, so you may distribute translations of the Document under the terms of section 4. Replacing Invariant Sections with translations requires special permission from their copyright holders, but you may include translations of some or all Invariant Sections in addition to the original versions of these Invariant Sections. You may include a translation of this License, and all the license notices in the Document, and any Warranty Disclaimers, provided that you also include the original English version of this License and the original versions of those notices and disclaimers. In case of a disagreement between the translation and the original version of this License or a notice or disclaimer, the original version will prevail. If a section in the Document is Entitled ``Acknowledgements'', ``Dedications'', or ``History'', the requirement (section 4) to Preserve its Title (section 1) will typically require changing the actual title. @item TERMINATION You may not copy, modify, sublicense, or distribute the Document except as expressly provided for under this License. Any other attempt to copy, modify, sublicense or distribute the Document is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. @item FUTURE REVISIONS OF THIS LICENSE The Free Software Foundation may publish new, revised versions of the GNU Free Documentation License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. See @uref{http://www.gnu.org/copyleft/}. Each version of the License is given a distinguishing version number. If the Document specifies that a particular numbered version of this License ``or any later version'' applies to it, you have the option of following the terms and conditions either of that specified version or of any later version that has been published (not as a draft) by the Free Software Foundation. If the Document does not specify a version number of this License, you may choose any version ever published (not as a draft) by the Free Software Foundation. @end enumerate @page @heading ADDENDUM: How to use this License for your documents To use this License in a document you have written, include a copy of the License in the document and put the following copyright and license notices just after the title page: @smallexample @group Copyright (C) @var{year} @var{your name}. Permission is granted to copy, distribute and/or modify this document under the terms of the GNU Free Documentation License, Version 1.2 or any later version published by the Free Software Foundation; with no Invariant Sections, no Front-Cover Texts, and no Back-Cover Texts. A copy of the license is included in the section entitled ``GNU Free Documentation License''. @end group @end smallexample If you have Invariant Sections, Front-Cover Texts and Back-Cover Texts, replace the ``with@dots{}Texts.'' line with this: @smallexample @group with the Invariant Sections being @var{list their titles}, with the Front-Cover Texts being @var{list}, and with the Back-Cover Texts being @var{list}. @end group @end smallexample If you have Invariant Sections without Cover Texts, or some other combination of the three, merge those two alternatives to suit the situation. If your document contains nontrivial examples of program code, we recommend releasing these examples in parallel under your choice of free software license, such as the GNU General Public License, to permit their use in free software. @c Local Variables: @c ispell-local-pdict: "ispell-dict" @c End: intercal-0.29/doc/fixtoc.pl0000755000175000017500000000050111443403051015511 0ustar brooniebroonie#!/bin/perl -w # Deindent and delink part headings in the TOC, and remove the initial # H2 entry. my $f=1; while(<>) { $f and /
    / and do{$f=0; next;}; /^
  • ]*>C-INTERCAL / and next; s%^
  • ]*>(PART .*?)%

$1