From 6ab0c0f5bf14ed9c15370407b9ee7e0b4b089ae1 Mon Sep 17 00:00:00 2001 From: Igor Pashev Date: Sun, 27 Jan 2013 23:51:56 +0000 Subject: Initial upstream version 9.4.3 --- src/Makefile | 31 + src/common/Makefile | 91 + src/common/alloc.c | 65 + src/common/dlrgint.c | 252 ++ src/common/doincl.c | 77 + src/common/error.h | 179 ++ src/common/filepart.c | 218 ++ src/common/fixgram.icn | 48 + src/common/getopt.c | 57 + src/common/icontype.h | 55 + src/common/identify.c | 30 + src/common/infer.c | 33 + src/common/ipp.c | 971 ++++++++ src/common/lextab.h | 576 +++++ src/common/literals.c | 180 ++ src/common/long.c | 34 + src/common/mktoktab.icn | 507 ++++ src/common/munix.c | 258 ++ src/common/op.txt | 61 + src/common/patchstr.c | 189 ++ src/common/pscript.icn | 44 + src/common/rtdb.c | 1692 ++++++++++++++ src/common/strtbl.c | 207 ++ src/common/time.c | 34 + src/common/tokens.txt | 76 + src/common/typespec.icn | 482 ++++ src/common/typespec.txt | 87 + src/common/xwindow.c | 159 ++ src/common/yacctok.h | 125 + src/common/yylex.h | 624 +++++ src/h/config.h | 309 +++ src/h/cpuconf.h | 247 ++ src/h/cstructs.h | 317 +++ src/h/esctab.h | 38 + src/h/fdefs.h | 232 ++ src/h/features.h | 77 + src/h/grammar.h | 273 +++ src/h/graphics.h | 447 ++++ src/h/grttin.h | 278 +++ src/h/gsupport.h | 13 + src/h/header.h | 28 + src/h/kdefs.h | 70 + src/h/lexdef.h | 75 + src/h/monitor.h | 213 ++ src/h/mproto.h | 54 + src/h/mswin.h | 201 ++ src/h/odefs.h | 54 + src/h/opdefs.h | 140 ++ src/h/parserr.h | 177 ++ src/h/rexterns.h | 223 ++ src/h/rmacros.h | 687 ++++++ src/h/rproto.h | 481 ++++ src/h/rstructs.h | 555 +++++ src/h/rt.h | 27 + src/h/sys.h | 75 + src/h/typedefs.h | 81 + src/h/version.h | 66 + src/h/xwin.h | 194 ++ src/iconc/Makefile | 73 + src/iconc/ccode.c | 4954 +++++++++++++++++++++++++++++++++++++++ src/iconc/ccode.h | 252 ++ src/iconc/ccomp.c | 130 ++ src/iconc/cglobals.h | 50 + src/iconc/cgrammar.c | 221 ++ src/iconc/chkinv.c | 545 +++++ src/iconc/clex.c | 18 + src/iconc/cmain.c | 424 ++++ src/iconc/cmem.c | 114 + src/iconc/codegen.c | 1918 +++++++++++++++ src/iconc/cparse.c | 1940 +++++++++++++++ src/iconc/cproto.h | 165 ++ src/iconc/csym.c | 853 +++++++ src/iconc/csym.h | 380 +++ src/iconc/ctoken.h | 111 + src/iconc/ctrans.c | 184 ++ src/iconc/ctrans.h | 47 + src/iconc/ctree.c | 777 ++++++ src/iconc/ctree.h | 200 ++ src/iconc/dbase.c | 196 ++ src/iconc/fixcode.c | 372 +++ src/iconc/incheck.c | 802 +++++++ src/iconc/inline.c | 2007 ++++++++++++++++ src/iconc/ivalues.c | 51 + src/iconc/lifetime.c | 496 ++++ src/iconc/types.c | 893 +++++++ src/iconc/typinfer.c | 5189 +++++++++++++++++++++++++++++++++++++++++ src/icont/Makefile | 108 + src/icont/ixhdr.c | 73 + src/icont/keyword.h | 70 + src/icont/lcode.c | 1564 +++++++++++++ src/icont/lfile.h | 21 + src/icont/lglob.c | 356 +++ src/icont/link.c | 228 ++ src/icont/link.h | 143 ++ src/icont/llex.c | 318 +++ src/icont/lmem.c | 224 ++ src/icont/lnklist.c | 83 + src/icont/lsym.c | 446 ++++ src/icont/mkkwd.icn | 52 + src/icont/newhdr.c | 90 + src/icont/opcode.c | 117 + src/icont/opcode.h | 17 + src/icont/tcode.c | 1097 +++++++++ src/icont/tglobals.c | 24 + src/icont/tglobals.h | 67 + src/icont/tgrammar.c | 239 ++ src/icont/tlex.c | 16 + src/icont/tmem.c | 76 + src/icont/tparse.c | 1917 +++++++++++++++ src/icont/tproto.h | 106 + src/icont/trans.c | 125 + src/icont/trash.icn | 35 + src/icont/tree.c | 175 ++ src/icont/tree.h | 109 + src/icont/tsym.c | 519 +++++ src/icont/tsym.h | 69 + src/icont/ttoken.h | 111 + src/icont/tunix.c | 420 ++++ src/icont/util.c | 93 + src/preproc/Makefile | 34 + src/preproc/README | 7 + src/preproc/bldtok.c | 766 ++++++ src/preproc/evaluate.c | 561 +++++ src/preproc/files.c | 257 ++ src/preproc/gettok.c | 252 ++ src/preproc/macro.c | 659 ++++++ src/preproc/pchars.c | 157 ++ src/preproc/perr.c | 157 ++ src/preproc/pinit.c | 251 ++ src/preproc/pmain.c | 109 + src/preproc/pmem.c | 339 +++ src/preproc/pout.c | 230 ++ src/preproc/pproto.h | 64 + src/preproc/preproc.c | 991 ++++++++ src/preproc/preproc.h | 202 ++ src/preproc/ptoken.h | 48 + src/rtt/Makefile | 87 + src/rtt/ltoken.h | 117 + src/rtt/rtt.h | 2 + src/rtt/rtt1.h | 187 ++ src/rtt/rttdb.c | 1440 ++++++++++++ src/rtt/rttgram.y | 1101 +++++++++ src/rtt/rttilc.c | 1402 +++++++++++ src/rtt/rttinlin.c | 1950 ++++++++++++++++ src/rtt/rttlex.c | 356 +++ src/rtt/rttmain.c | 402 ++++ src/rtt/rttmisc.c | 114 + src/rtt/rttnode.c | 264 +++ src/rtt/rttout.c | 3821 ++++++++++++++++++++++++++++++ src/rtt/rttparse.c | 2992 ++++++++++++++++++++++++ src/rtt/rttproto.h | 92 + src/rtt/rttsym.c | 722 ++++++ src/runtime/Makefile | 514 ++++ src/runtime/cnv.r | 1157 +++++++++ src/runtime/data.r | 401 ++++ src/runtime/def.r | 168 ++ src/runtime/errmsg.r | 119 + src/runtime/extcall.r | 21 + src/runtime/fconv.r | 260 +++ src/runtime/fload.r | 221 ++ src/runtime/fmath.r | 114 + src/runtime/fmisc.r | 2204 +++++++++++++++++ src/runtime/fmonitr.r | 273 +++ src/runtime/fscan.r | 149 ++ src/runtime/fstr.r | 720 ++++++ src/runtime/fstranl.r | 260 +++ src/runtime/fstruct.r | 906 +++++++ src/runtime/fsys.r | 1107 +++++++++ src/runtime/fwindow.r | 2720 +++++++++++++++++++++ src/runtime/imain.r | 384 +++ src/runtime/imisc.r | 357 +++ src/runtime/init.r | 1118 +++++++++ src/runtime/interp.r | 1818 +++++++++++++++ src/runtime/invoke.r | 377 +++ src/runtime/keyword.r | 752 ++++++ src/runtime/lmisc.r | 176 ++ src/runtime/oarith.r | 502 ++++ src/runtime/oasgn.r | 522 +++++ src/runtime/ocat.r | 120 + src/runtime/ocomp.r | 177 ++ src/runtime/omisc.r | 284 +++ src/runtime/oref.r | 881 +++++++ src/runtime/oset.r | 299 +++ src/runtime/ovalue.r | 72 + src/runtime/ralc.r | 784 +++++++ src/runtime/rcoexpr.r | 315 +++ src/runtime/rcolor.r | 722 ++++++ src/runtime/rcomp.r | 444 ++++ src/runtime/rdebug.r | 1019 ++++++++ src/runtime/rimage.r | 930 ++++++++ src/runtime/rlrgint.r | 2302 ++++++++++++++++++ src/runtime/rmemmgt.r | 1459 ++++++++++++ src/runtime/rmisc.r | 1803 ++++++++++++++ src/runtime/rmswin.ri | 4204 +++++++++++++++++++++++++++++++++ src/runtime/rstruct.r | 665 ++++++ src/runtime/rsys.r | 252 ++ src/runtime/rwindow.r | 1727 ++++++++++++++ src/runtime/rwinrsc.r | 49 + src/runtime/rwinsys.r | 17 + src/runtime/rxrsc.ri | 995 ++++++++ src/runtime/rxwin.ri | 3475 +++++++++++++++++++++++++++ src/wincap/Makefile | 24 + src/wincap/copy.c | 338 +++ src/wincap/dibapi.h | 46 + src/wincap/dibutil.c | 680 ++++++ src/wincap/dibutil.h | 40 + src/wincap/errors.c | 51 + src/wincap/errors.h | 33 + src/wincap/file.c | 410 ++++ src/wincap/license.txt | 40 + src/xpm/Makefile | 28 + src/xpm/XpmCrDataFI.c | 417 ++++ src/xpm/XpmCrDataFP.c | 75 + src/xpm/XpmCrIFData.c | 52 + src/xpm/XpmCrPFData.c | 92 + src/xpm/XpmRdFToData.c | 115 + src/xpm/XpmRdFToI.c | 110 + src/xpm/XpmRdFToP.c | 92 + src/xpm/XpmWrFFrData.c | 113 + src/xpm/XpmWrFFrI.c | 341 +++ src/xpm/XpmWrFFrP.c | 75 + src/xpm/converters/ppm.README | 69 + src/xpm/converters/ppmtoxpm.1 | 69 + src/xpm/converters/ppmtoxpm.c | 481 ++++ src/xpm/converters/xpm1to3.pl | 90 + src/xpm/converters/xpmtoppm.1 | 28 + src/xpm/converters/xpmtoppm.c | 433 ++++ src/xpm/create.c | 963 ++++++++ src/xpm/data.c | 422 ++++ src/xpm/doc/CHANGES | 422 ++++ src/xpm/doc/COPYRIGHT | 30 + src/xpm/doc/FILES | 42 + src/xpm/doc/Imakefile | 59 + src/xpm/doc/Makefile | 433 ++++ src/xpm/doc/Makefile.noXtree | 85 + src/xpm/doc/README | 176 ++ src/xpm/doc/colas.sty | 294 +++ src/xpm/doc/name-3.0b-3.0c | 48 + src/xpm/doc/name-3.0c-3.0 | 32 + src/xpm/doc/plaid.xpm | 34 + src/xpm/doc/plaid_mask.xpm | 35 + src/xpm/doc/xpm.tex | 849 +++++++ src/xpm/hashtable.c | 205 ++ src/xpm/misc.c | 206 ++ src/xpm/parse.c | 537 +++++ src/xpm/rename | 24 + src/xpm/rgb.c | 136 ++ src/xpm/scan.c | 567 +++++ src/xpm/sxpm.c | 580 +++++ src/xpm/sxpm.man | 89 + src/xpm/xpm.h | 237 ++ src/xpm/xpmP.h | 279 +++ 252 files changed, 117118 insertions(+) create mode 100644 src/Makefile create mode 100644 src/common/Makefile create mode 100644 src/common/alloc.c create mode 100644 src/common/dlrgint.c create mode 100644 src/common/doincl.c create mode 100644 src/common/error.h create mode 100644 src/common/filepart.c create mode 100644 src/common/fixgram.icn create mode 100644 src/common/getopt.c create mode 100644 src/common/icontype.h create mode 100644 src/common/identify.c create mode 100644 src/common/infer.c create mode 100644 src/common/ipp.c create mode 100644 src/common/lextab.h create mode 100644 src/common/literals.c create mode 100644 src/common/long.c create mode 100644 src/common/mktoktab.icn create mode 100644 src/common/munix.c create mode 100644 src/common/op.txt create mode 100644 src/common/patchstr.c create mode 100644 src/common/pscript.icn create mode 100644 src/common/rtdb.c create mode 100644 src/common/strtbl.c create mode 100644 src/common/time.c create mode 100644 src/common/tokens.txt create mode 100644 src/common/typespec.icn create mode 100644 src/common/typespec.txt create mode 100644 src/common/xwindow.c create mode 100644 src/common/yacctok.h create mode 100644 src/common/yylex.h create mode 100644 src/h/config.h create mode 100644 src/h/cpuconf.h create mode 100644 src/h/cstructs.h create mode 100644 src/h/esctab.h create mode 100644 src/h/fdefs.h create mode 100644 src/h/features.h create mode 100644 src/h/grammar.h create mode 100644 src/h/graphics.h create mode 100644 src/h/grttin.h create mode 100644 src/h/gsupport.h create mode 100644 src/h/header.h create mode 100644 src/h/kdefs.h create mode 100644 src/h/lexdef.h create mode 100644 src/h/monitor.h create mode 100644 src/h/mproto.h create mode 100644 src/h/mswin.h create mode 100644 src/h/odefs.h create mode 100644 src/h/opdefs.h create mode 100644 src/h/parserr.h create mode 100644 src/h/rexterns.h create mode 100644 src/h/rmacros.h create mode 100644 src/h/rproto.h create mode 100644 src/h/rstructs.h create mode 100644 src/h/rt.h create mode 100644 src/h/sys.h create mode 100644 src/h/typedefs.h create mode 100644 src/h/version.h create mode 100644 src/h/xwin.h create mode 100644 src/iconc/Makefile create mode 100644 src/iconc/ccode.c create mode 100644 src/iconc/ccode.h create mode 100644 src/iconc/ccomp.c create mode 100644 src/iconc/cglobals.h create mode 100644 src/iconc/cgrammar.c create mode 100644 src/iconc/chkinv.c create mode 100644 src/iconc/clex.c create mode 100644 src/iconc/cmain.c create mode 100644 src/iconc/cmem.c create mode 100644 src/iconc/codegen.c create mode 100644 src/iconc/cparse.c create mode 100644 src/iconc/cproto.h create mode 100644 src/iconc/csym.c create mode 100644 src/iconc/csym.h create mode 100644 src/iconc/ctoken.h create mode 100644 src/iconc/ctrans.c create mode 100644 src/iconc/ctrans.h create mode 100644 src/iconc/ctree.c create mode 100644 src/iconc/ctree.h create mode 100644 src/iconc/dbase.c create mode 100644 src/iconc/fixcode.c create mode 100644 src/iconc/incheck.c create mode 100644 src/iconc/inline.c create mode 100644 src/iconc/ivalues.c create mode 100644 src/iconc/lifetime.c create mode 100644 src/iconc/types.c create mode 100644 src/iconc/typinfer.c create mode 100644 src/icont/Makefile create mode 100644 src/icont/ixhdr.c create mode 100644 src/icont/keyword.h create mode 100644 src/icont/lcode.c create mode 100644 src/icont/lfile.h create mode 100644 src/icont/lglob.c create mode 100644 src/icont/link.c create mode 100644 src/icont/link.h create mode 100644 src/icont/llex.c create mode 100644 src/icont/lmem.c create mode 100644 src/icont/lnklist.c create mode 100644 src/icont/lsym.c create mode 100644 src/icont/mkkwd.icn create mode 100644 src/icont/newhdr.c create mode 100644 src/icont/opcode.c create mode 100644 src/icont/opcode.h create mode 100644 src/icont/tcode.c create mode 100644 src/icont/tglobals.c create mode 100644 src/icont/tglobals.h create mode 100644 src/icont/tgrammar.c create mode 100644 src/icont/tlex.c create mode 100644 src/icont/tmem.c create mode 100644 src/icont/tparse.c create mode 100644 src/icont/tproto.h create mode 100644 src/icont/trans.c create mode 100644 src/icont/trash.icn create mode 100644 src/icont/tree.c create mode 100644 src/icont/tree.h create mode 100644 src/icont/tsym.c create mode 100644 src/icont/tsym.h create mode 100644 src/icont/ttoken.h create mode 100644 src/icont/tunix.c create mode 100644 src/icont/util.c create mode 100644 src/preproc/Makefile create mode 100644 src/preproc/README create mode 100644 src/preproc/bldtok.c create mode 100644 src/preproc/evaluate.c create mode 100644 src/preproc/files.c create mode 100644 src/preproc/gettok.c create mode 100644 src/preproc/macro.c create mode 100644 src/preproc/pchars.c create mode 100644 src/preproc/perr.c create mode 100644 src/preproc/pinit.c create mode 100644 src/preproc/pmain.c create mode 100644 src/preproc/pmem.c create mode 100644 src/preproc/pout.c create mode 100644 src/preproc/pproto.h create mode 100644 src/preproc/preproc.c create mode 100644 src/preproc/preproc.h create mode 100644 src/preproc/ptoken.h create mode 100644 src/rtt/Makefile create mode 100644 src/rtt/ltoken.h create mode 100644 src/rtt/rtt.h create mode 100644 src/rtt/rtt1.h create mode 100644 src/rtt/rttdb.c create mode 100644 src/rtt/rttgram.y create mode 100644 src/rtt/rttilc.c create mode 100644 src/rtt/rttinlin.c create mode 100644 src/rtt/rttlex.c create mode 100644 src/rtt/rttmain.c create mode 100644 src/rtt/rttmisc.c create mode 100644 src/rtt/rttnode.c create mode 100644 src/rtt/rttout.c create mode 100644 src/rtt/rttparse.c create mode 100644 src/rtt/rttproto.h create mode 100644 src/rtt/rttsym.c create mode 100644 src/runtime/Makefile create mode 100644 src/runtime/cnv.r create mode 100644 src/runtime/data.r create mode 100644 src/runtime/def.r create mode 100644 src/runtime/errmsg.r create mode 100644 src/runtime/extcall.r create mode 100644 src/runtime/fconv.r create mode 100644 src/runtime/fload.r create mode 100644 src/runtime/fmath.r create mode 100644 src/runtime/fmisc.r create mode 100644 src/runtime/fmonitr.r create mode 100644 src/runtime/fscan.r create mode 100644 src/runtime/fstr.r create mode 100644 src/runtime/fstranl.r create mode 100644 src/runtime/fstruct.r create mode 100644 src/runtime/fsys.r create mode 100644 src/runtime/fwindow.r create mode 100644 src/runtime/imain.r create mode 100644 src/runtime/imisc.r create mode 100644 src/runtime/init.r create mode 100644 src/runtime/interp.r create mode 100644 src/runtime/invoke.r create mode 100644 src/runtime/keyword.r create mode 100644 src/runtime/lmisc.r create mode 100644 src/runtime/oarith.r create mode 100644 src/runtime/oasgn.r create mode 100644 src/runtime/ocat.r create mode 100644 src/runtime/ocomp.r create mode 100644 src/runtime/omisc.r create mode 100644 src/runtime/oref.r create mode 100644 src/runtime/oset.r create mode 100644 src/runtime/ovalue.r create mode 100644 src/runtime/ralc.r create mode 100644 src/runtime/rcoexpr.r create mode 100644 src/runtime/rcolor.r create mode 100644 src/runtime/rcomp.r create mode 100644 src/runtime/rdebug.r create mode 100644 src/runtime/rimage.r create mode 100644 src/runtime/rlrgint.r create mode 100644 src/runtime/rmemmgt.r create mode 100644 src/runtime/rmisc.r create mode 100644 src/runtime/rmswin.ri create mode 100644 src/runtime/rstruct.r create mode 100644 src/runtime/rsys.r create mode 100644 src/runtime/rwindow.r create mode 100644 src/runtime/rwinrsc.r create mode 100644 src/runtime/rwinsys.r create mode 100644 src/runtime/rxrsc.ri create mode 100644 src/runtime/rxwin.ri create mode 100644 src/wincap/Makefile create mode 100644 src/wincap/copy.c create mode 100644 src/wincap/dibapi.h create mode 100644 src/wincap/dibutil.c create mode 100644 src/wincap/dibutil.h create mode 100644 src/wincap/errors.c create mode 100644 src/wincap/errors.h create mode 100644 src/wincap/file.c create mode 100644 src/wincap/license.txt create mode 100644 src/xpm/Makefile create mode 100644 src/xpm/XpmCrDataFI.c create mode 100644 src/xpm/XpmCrDataFP.c create mode 100644 src/xpm/XpmCrIFData.c create mode 100644 src/xpm/XpmCrPFData.c create mode 100644 src/xpm/XpmRdFToData.c create mode 100644 src/xpm/XpmRdFToI.c create mode 100644 src/xpm/XpmRdFToP.c create mode 100644 src/xpm/XpmWrFFrData.c create mode 100644 src/xpm/XpmWrFFrI.c create mode 100644 src/xpm/XpmWrFFrP.c create mode 100644 src/xpm/converters/ppm.README create mode 100644 src/xpm/converters/ppmtoxpm.1 create mode 100644 src/xpm/converters/ppmtoxpm.c create mode 100644 src/xpm/converters/xpm1to3.pl create mode 100644 src/xpm/converters/xpmtoppm.1 create mode 100644 src/xpm/converters/xpmtoppm.c create mode 100644 src/xpm/create.c create mode 100644 src/xpm/data.c create mode 100644 src/xpm/doc/CHANGES create mode 100644 src/xpm/doc/COPYRIGHT create mode 100644 src/xpm/doc/FILES create mode 100644 src/xpm/doc/Imakefile create mode 100644 src/xpm/doc/Makefile create mode 100644 src/xpm/doc/Makefile.noXtree create mode 100644 src/xpm/doc/README create mode 100644 src/xpm/doc/colas.sty create mode 100644 src/xpm/doc/name-3.0b-3.0c create mode 100644 src/xpm/doc/name-3.0c-3.0 create mode 100644 src/xpm/doc/plaid.xpm create mode 100644 src/xpm/doc/plaid_mask.xpm create mode 100644 src/xpm/doc/xpm.tex create mode 100644 src/xpm/hashtable.c create mode 100644 src/xpm/misc.c create mode 100644 src/xpm/parse.c create mode 100755 src/xpm/rename create mode 100644 src/xpm/rgb.c create mode 100644 src/xpm/scan.c create mode 100644 src/xpm/sxpm.c create mode 100644 src/xpm/sxpm.man create mode 100644 src/xpm/xpm.h create mode 100644 src/xpm/xpmP.h (limited to 'src') diff --git a/src/Makefile b/src/Makefile new file mode 100644 index 0000000..2aaa971 --- /dev/null +++ b/src/Makefile @@ -0,0 +1,31 @@ +# Icon source Makefile, normally used only for cleanup. + + +what: + @echo "What do you want to make?" + +Clean Pure: + cd iconc; rm -f *.o iconc + cd common; rm -f *.o doincl patchstr infer + cd preproc; rm -f *.o pp + cd rtt; rm -f *.o rtt + cd runtime; rm -f *.o *.c rt.db rt.a rttcur.lst rttfull.lst iconx + cd icont; rm -f *.o icont hdr.h ixhdr.hdr newhdr + cd wincap; rm -f *.o *.a + cd xpm; rm -f *.o *.a +# force full runtime system rebuild + touch h/define.h + rm -f h/arch.h + + +# The following entry forces rebuilding of everthing from first-generation +# files, even files not normally recreated. Doing this requires uncommenting +# some lines in common/Makefile, icont/Makefile, and iconc/Makefile. + +Force-rebuild: Clean + cd h; rm -f kdefs.h + cd common; rm -f *.o yacctok.h lextab.h icontype.h \ + doincl fixgram mktoktab patchstr pscript typespec + cd icont; rm -f *.o icont mkkwd trash \ + hdr.h keyword.h tgram.g ttoken.h tparse.c + cd iconc; rm -f *.o iconc cgram.g ctoken.h cparse.h diff --git a/src/common/Makefile b/src/common/Makefile new file mode 100644 index 0000000..bb5546a --- /dev/null +++ b/src/common/Makefile @@ -0,0 +1,91 @@ +include ../../Makedefs + + +OBJS = long.o getopt.o time.o filepart.o identify.o strtbl.o rtdb.o\ + munix.o literals.o rswitch.o alloc.o long.o getopt.o time.o\ + xwindow.o dlrgint.o ipp.o + +common: doincl $(OBJS) gpxmaybe + +doincl: doincl.c ../h/arch.h + $(CC) $(CFLAGS) -o doincl doincl.c + -./doincl -o ../../bin/rt.h ../h/rt.h + +patchstr: patchstr.c + $(CC) $(CFLAGS) -o patchstr patchstr.c + +gpxmaybe: + -if [ "x$(XL)" != "x" ]; then $(MAKE) $(GDIR); fi + +xpm: + cd ../xpm; $(MAKE) libXpm.a + cp -p ../xpm/libXpm.a ../../bin/libIgpx.a + +wincap: + cd ../wincap; $(MAKE) libWincap.a + cp -u ../wincap/libWincap.a ../../bin/libIgpx.a + +$(OBJS): ../h/define.h ../h/arch.h ../h/config.h ../h/cstructs.h \ + ../h/typedefs.h ../h/mproto.h ../h/cpuconf.h + +../h/arch.h: infer.c + $(CC) $(CFLAGS) -o infer infer.c + ./infer >../h/arch.h + +identify.o: ../h/version.h + +ipp.o: ../h/features.h + +literals.o: ../h/esctab.h + +rtdb.o: ../h/version.h icontype.h + +dlrgint.o: ../h/rproto.h ../h/rexterns.h ../h/rmacros.h ../h/rstructs.h + +xwindow.o: ../h/graphics.h ../h/xwin.h + +# for rswitch, $(CFLAGS) is deliberately omitted (-O may cause problems) +rswitch.o: ../h/define.h ../h/arch.h $(RSW) + $(CC) -c $(RSW) + + +# The following section is needed if changes are made to the Icon grammar, +# but it is not run as part of the normal installation process. If it is +# needed, it is run by changing ../icont/Makefile and/or ../iconc/Makefile; +# see the comments there for details. icont must be in the search path +# for this section to work. + +gfiles: lextab.h yacctok.h fixgram pscript + +lextab.h yacctok.h: tokens.txt op.txt mktoktab + ./mktoktab + +mktoktab: mktoktab.icn + icont -s mktoktab.icn + +fixgram: fixgram.icn + icont -s fixgram.icn + +pscript: pscript.icn + icont -s pscript.icn + + + +# The following section is commented out because it does not need to be +# performed unless changes are made to typespec.txt. Such changes +# and are not part of the installation process. However, if the +# distribution files are unloaded in a fashion such that their dates +# are not set properly, the following section would be attempted. +# +# Note that if any changes are made to the file mentioned above, the +# comment characters at the beginning of the following lines should be +# removed. +# +# Note that icont must be on your search path for this. +# +# +#icontype.h: typespec.txt typespec +# typespec icontype.h +# +#typespec: typespec.icn +# icont typespec diff --git a/src/common/alloc.c b/src/common/alloc.c new file mode 100644 index 0000000..7a048b1 --- /dev/null +++ b/src/common/alloc.c @@ -0,0 +1,65 @@ +/* + * alloc.c -- allocation routines for the Icon compiler + */ + +#include "../h/gsupport.h" + +#ifdef TypTrc + int typealloc = 0; /* type allocation switch */ + long typespace = 0; /* type allocation amount */ +#endif /* TypTrc */ + +/* + * salloc - allocate and initialize string + */ + +char *salloc(s) +char *s; + { + register char *s1; + + s1 = (char *)malloc(strlen(s) + 1); + if (s1 == NULL) { + fprintf(stderr, "salloc(%d): out of memory\n", (int)strlen(s) + 1); + exit(EXIT_FAILURE); + } + return strcpy(s1, s); + } + +/* + * alloc - allocate n bytes + */ + +pointer alloc(n) +unsigned int n; + { + register pointer a; + +#ifdef AllocTrace + static int sum = 0; +#endif /* AllocTrace */ + +#ifdef TypTrc + if (typealloc) + typespace += (long)n; +#endif /* TypTrc */ + +#ifdef AllocTrace + sum = sum + n; + if (sum > 5000) { + fprintf(stderr, "."); + fflush(stderr); + sum = 0; + }; +#endif /* AllocTrace */ + + if (n == 0) /* Work-around for 0 allocation */ + n = 1; + + a = calloc(n, sizeof(char)); + if (a == NULL) { + fprintf(stderr, "alloc(%d): out of memory\n", (int)n); + exit(EXIT_FAILURE); + } + return a; + } diff --git a/src/common/dlrgint.c b/src/common/dlrgint.c new file mode 100644 index 0000000..3ca79d1 --- /dev/null +++ b/src/common/dlrgint.c @@ -0,0 +1,252 @@ +/* + * dlrgint.c - versions of "large integer" routines for compiled programs + * that do not support large integers. + */ +#define COMPILER 1 +#include "../h/rt.h" + +/* + ***************************************************************** + * + * Routines in the first set are only called when large integers + * exist and thus these versions will never be called. They need + * only have the correct signature and compile without error. + */ + +/* + * bignum -> file + */ +void bigprint(f, da) +FILE *f; +dptr da; + { + } + +/* + * bignum -> real + */ +double bigtoreal(da) +dptr da; + { + return 0.0; + } + +/* + * bignum -> string + */ +int bigtos(da, dx) +dptr da, dx; + { + return 0; + } + +/* + * da -> dx + */ +int cpbignum(da, dx) +dptr da, dx; + { + return 0; + } + +/* + * da / db -> dx + */ +int bigdiv(da, db, dx) +dptr da, db, dx; + { + return 0; + } + +/* + * da % db -> dx + */ +int bigmod(da, db, dx) +dptr da, db, dx; + { + return 0; + } + +/* + * iand(da, db) -> dx + */ +int bigand(da, db, dx) +dptr da, db, dx; + { + return 0; + } + +/* + * ior(da, db) -> dx + */ +int bigor(da, db, dx) +dptr da, db, dx; + { + return 0; + } + +/* + * xor(da, db) -> dx + */ +int bigxor(da, db, dx) +dptr da, db, dx; + { + return 0; + } + +/* + * negative if da < db + * zero if da == db + * positive if da > db + */ +word bigcmp(da, db) +dptr da, db; + { + return (word)0; + } + +/* + * ?da -> dx + */ +int bigrand(da, dx) +dptr da, dx; + { + return 0; + } + +/* + ************************************************************* + * + * The following routines are called when overflow has occurred + * during ordinary arithmetic. + */ + +/* + * da + db -> dx + */ +int bigadd(da, db, dx) +dptr da, db; +dptr dx; + { + t_errornumber = 203; + t_errorvalue = nulldesc; + t_have_val = 0; + return Error; + } + +/* + * da * db -> dx + */ +int bigmul(da, db, dx) +dptr da, db, dx; + { + t_errornumber = 203; + t_errorvalue = nulldesc; + t_have_val = 0; + return Error; + } + +/* + * -i -> dx + */ +int bigneg(da, dx) +dptr da, dx; + { + t_errornumber = 203; + t_errorvalue = nulldesc; + t_have_val = 0; + return Error; + } + +/* + * da - db -> dx + */ +int bigsub(da, db, dx) +dptr da, db, dx; + { + t_errornumber = 203; + t_errorvalue = nulldesc; + t_have_val = 0; + return Error; + } + +/* + * ******************************************************** + * + * The remaining routines each requires different handling. + */ + +/* + * real -> bignum + */ +int realtobig(da, dx) +dptr da, dx; + { + return Failed; /* conversion cannot be done */ + } + +/* + * da ^ db -> dx + */ +int bigpow(da, db, dx) +dptr da, db, dx; + { + C_integer r; + extern int over_flow; + + /* + * Just do ordinary interger exponentiation and check for overflow. + */ + r = iipow(IntVal(*da), IntVal(*db)); + if (over_flow) { + k_errornumber = 203; + k_errortext = ""; + k_errorvalue = nulldesc; + have_errval = 0; + return Error; + } + MakeInt(r, dx); + return Succeeded; + } + +/* + * string -> bignum + */ +word bigradix(sign, r, s, end_s, result) +int sign; /* '-' or not */ +int r; /* radix 2 .. 36 */ +char *s, *end_s; /* input string */ +union numeric *result; /* output T_Integer or T_Lrgint */ + { + /* + * Just do string to ordinary integer. + */ + return radix(sign, r, s, end_s, result); + } + +/* + * bigshift(da, db) -> dx + */ +int bigshift(da, db, dx) +dptr da, db, dx; + { + uword ci; /* shift in 0s, even if negative */ + C_integer cj; + + /* + * Do an ordinary shift - note that db is always positive when this + * routine is called. + */ + ci = (uword)IntVal(*da); + cj = IntVal(*db); + /* + * Check for a shift of WordSize or greater; return an explicit 0 because + * this is beyond C's defined behavior. Otherwise shift as requested. + */ + if (cj >= WordBits) + ci = 0; + else + ci <<= cj; + MakeInt(ci, dx); + return Succeeded; + } diff --git a/src/common/doincl.c b/src/common/doincl.c new file mode 100644 index 0000000..8f80c87 --- /dev/null +++ b/src/common/doincl.c @@ -0,0 +1,77 @@ +/* + * doincl.c -- expand include directives (recursively) + * + * Usage: doinclude [-o outfile] filename... + * + * Doinclude copies a C source file, expanding non-system include directives. + * For each line of the form + * #include "filename" + * the named file is interpolated; all other lines are copied verbatim. + * + * No error is generated if a file cannot be opened. + */ + +#include "../h/rt.h" + +void doinclude (char *fname); + +#define MAXLINE 500 /* maximum line length */ + +FILE *outfile; /* output file */ + +int main(argc, argv) +int argc; +char *argv[]; + { + char *progname = argv[0]; + + outfile = stdout; + if (argc > 3 && strcmp(argv[1], "-o") == 0) { + if ((outfile = fopen(argv[2], "w")) != NULL) { + argv += 2; + argc -= 2; + } + else { + perror(argv[2]); + exit(1); + } + } + if (argc < 2) { + fprintf(stderr, "usage: %s [-o outfile] filename...\n", progname); + exit(1); + } + + fprintf(outfile, + "/***** do not edit -- this file was generated mechanically *****/\n\n"); + while (--argc > 0) + doinclude(*++argv); + exit(0); + /*NOTREACHED*/ + } + +void doinclude(fname) +char *fname; + { + FILE *f; + char line[MAXLINE], newname[MAXLINE], *p; + + fprintf(outfile, "\n\n/****************************************"); + fprintf(outfile, " from %s: */\n\n", fname); + if ((f = fopen(fname, "r")) != NULL) { + while (fgets(line, MAXLINE, f)) + if (sscanf(line, " # include \"%s\"", newname) == 1) { + for (p = newname; *p != '\0' && *p != '"'; p++) + ; + *p = '\0'; /* strip off trailing '"' */ + doinclude(newname); /* include file */ + } + else + fputs(line, outfile); /* not an include directive */ + fclose(f); + } + else { + fprintf(outfile, "/* [file not found] */\n"); + } + fprintf(outfile, "\n/****************************************"); + fprintf(outfile, " end %s */\n", fname); + } diff --git a/src/common/error.h b/src/common/error.h new file mode 100644 index 0000000..0c5cb83 --- /dev/null +++ b/src/common/error.h @@ -0,0 +1,179 @@ +/* + * error.h -- routines for producing error messages. + * + * This source file contains the routines for issuing error messages. + * It is built by inclusion in ../icont/tlex.c and ../iconc/clex.c, + * with slight variations depending on whether "Iconc" is defined. + */ + +/* + * Prototype. + */ + +static char *mapterm (int typ,struct node *val); + +/* + * yyerror produces syntax error messages. tok is the offending token + * (yychar), lval is yylval, and state is the parser's state. + * + * errtab is searched for the state, if it is found, the associated + * message is produced; if the state isn't found, "syntax error" + * is produced. + */ +void yyerror(tok, lval, state) +int tok, state; +nodeptr lval; + { + register struct errmsg *p; + int line; + + if (lval == NULL) + line = 0; + else + line = Line(lval); + + if (tok_loc.n_file) + fprintf(stderr, "File %s; ", tok_loc.n_file); + if (tok == EOFX) /* special case end of file */ + fprintf(stderr, "unexpected end of file\n"); + else { + fprintf(stderr, "Line %d # ", line); + if (Col(lval)) + fprintf(stderr, "\"%s\": ", mapterm(tok,lval)); + for (p = errtab; p->e_state != state && p->e_state >= 0; p++) ; + fprintf(stderr, "%s\n", p->e_mesg); + } + tfatals++; + nocode++; + } + +/* + * mapterm finds a printable string for the given token type + * and value. + */ +static char *mapterm(typ,val) +int typ; +nodeptr val; + { + register struct toktab *t; + register struct optab *ot; + register int i; + + i = typ; + if (i == IDENT || i == INTLIT || i == REALLIT || i == STRINGLIT || + i == CSETLIT) + return Str0(val); + for (t = toktab; t->t_type != 0; t++) + if (t->t_type == i) + return t->t_word; + for (ot = optab; ot->tok.t_type != 0; ot++) + if (ot->tok.t_type == i) + return ot->tok.t_word; + return "???"; + } + +/* + * tfatal produces the translator error messages s1 and s2 (if nonnull). The + * location of the error is found in tok_loc. + */ +void tfatal(s1, s2) +char *s1, *s2; + { + + if (tok_loc.n_file) + fprintf(stderr, "File %s; ", tok_loc.n_file); + fprintf(stderr, "Line %d # ", tok_loc.n_line); + if (s2) + fprintf(stderr, "\"%s\": ", s2); + fprintf(stderr, "%s\n", s1); + tfatals++; + nocode++; + } + +/* + * nfatal produces the error messages s1 and s2 (if nonnull), and associates + * it with source location of node. + */ +void nfatal(n, s1, s2) +nodeptr n; +char *s1, *s2; + { + + if (n != NULL) { + fprintf(stderr, "File %s; ", File(n)); + fprintf(stderr, "Line %d # ", Line(n)); + } + if (s2) + fprintf(stderr, "\"%s\": ", s2); + fprintf(stderr, "%s\n", s1); + tfatals++; + nocode++; + } + +#ifdef Iconc +/* + * twarn produces s1 and s2 (if nonnull) as translator warning messages. + * The location of the error is found in tok_loc. + */ +void twarn(s1, s2) +char *s1, *s2; + { + + if (tok_loc.n_file) + fprintf(stderr, "File %s; ", tok_loc.n_file); + fprintf(stderr, "Line %d # ", tok_loc.n_line); + if (s2) + fprintf(stderr, "\"%s\": ", s2); + fprintf(stderr, "%s\n", s1); + twarns++; + } +#endif /* Iconc */ + +/* + * tsyserr is called for fatal errors. The message s is produced and the + * translator exits. + */ +void tsyserr(s) +char *s; + { + + + if (tok_loc.n_file) + fprintf(stderr, "File %s; ", tok_loc.n_file); + fprintf(stderr, "Line %d # %s\n", in_line, s); + + exit(EXIT_FAILURE); + } + +/* + * quit - immediate exit with error message + */ + +void quit(msg) +char *msg; + { + quitf(msg,""); + } + +/* + * quitf - immediate exit with message format and argument + */ +void quitf(msg,arg) +char *msg, *arg; + { + extern char *progname; + + fprintf(stderr,"%s: ",progname); + fprintf(stderr,msg,arg); + fprintf(stderr,"\n"); + + #if !defined(Iconc) + { + extern char *ofile; + if (ofile) + remove(ofile); /* remove bad icode file */ + } + #endif /* !Iconc */ + + exit(EXIT_FAILURE); + } diff --git a/src/common/filepart.c b/src/common/filepart.c new file mode 100644 index 0000000..ab8049a --- /dev/null +++ b/src/common/filepart.c @@ -0,0 +1,218 @@ +/* + * This file contains pathfind(), fparse(), makename(), and smatch(). + */ +#include "../h/gsupport.h" + +static char *pathelem (char *s, char *buf); +static char *tryfile (char *buf, char *dir, char *name, char *extn); + +/* + * Define symbols for building file names. + * 1. Prefix: the characters that terminate a file name prefix + * 2. FileSep: the char to insert after a dir name, if any + * 3. DefPath: the default IPATH/LPATH + * 4. PathSep: allowable IPATH/LPATH separators + * + * All platforms use POSIX forms of file paths. + * MS Windows implementations canonize local forms before parsing. + */ + +#define Prefix "/" +#define FileSep '/' +#define PathSep " :" +#define DefPath "" + +/* + * pathfind(buf,path,name,extn) -- find file in path and return name. + * + * pathfind looks for a file on a path, begining with the current + * directory. Details vary by platform, but the general idea is + * that the file must be a readable simple text file. pathfind + * returns buf if it finds a file or NULL if not. + * + * buf[MaxPath] is a buffer in which to put the constructed file name. + * path is the IPATH or LPATH value, or NULL if unset. + * name is the file name. + * extn is the file extension (.icn or .u1) to be appended, or NULL if none. + */ +char *pathfind(buf, path, name, extn) +char *buf, *path, *name, *extn; + { + char *s; + char pbuf[MaxPath]; + + if (tryfile(buf, (char *)NULL, name, extn)) /* try curr directory first */ + return buf; + if (!path) /* if no path, use default */ + path = DefPath; + + #if CYGWIN + s = alloca(cygwin_win32_to_posix_path_list_buf_size(path)); + cygwin_win32_to_posix_path_list(path, s); + #else /* CYGWIN */ + s = path; + #endif /* CYGWIN */ + + while ((s = pathelem(s, pbuf)) != 0) /* for each path element */ + if (tryfile(buf, pbuf, name, extn)) /* look for file */ + return buf; + return NULL; /* return NULL if no file found */ + } + +/* + * pathelem(s,buf) -- copy next path element from s to buf. + * + * Returns the updated pointer s. + */ +static char *pathelem(s, buf) +char *s, *buf; + { + char c; + + while ((c = *s) != '\0' && strchr(PathSep, c)) + s++; + if (!*s) + return NULL; + while ((c = *s) != '\0' && !strchr(PathSep, c)) { + *buf++ = c; + s++; + } + + #ifdef FileSep + /* + * We have to append a path separator here. + * Seems like makename should really be the one to do that. + */ + if (!strchr(Prefix, buf[-1])) { /* if separator not already there */ + *buf++ = FileSep; + } + #endif /* FileSep */ + + *buf = '\0'; + return s; + } + +/* + * tryfile(buf, dir, name, extn) -- check to see if file is readable. + * + * The file name is constructed in buf from dir + name + extn. + * findfile returns buf if successful or NULL if not. + */ +static char *tryfile(buf, dir, name, extn) +char *buf, *dir, *name, *extn; + { + FILE *f; + makename(buf, dir, name, extn); + if ((f = fopen(buf, "r")) != NULL) { + fclose(f); + return buf; + } + else + return NULL; + } + +/* + * fparse - break a file name down into component parts. + * Result is a pointer to a struct of static pointers good until the next call. + */ +struct fileparts *fparse(s) +char *s; + { + static char buf[MaxPath+2]; + static struct fileparts fp; + int n; + char *p, *q; + + #if CYGWIN + char posix_s[_POSIX_PATH_MAX + 1]; + cygwin_conv_to_posix_path(s, posix_s); + s = posix_s; + #endif /* CYGWIN */ + + q = s; + fp.ext = p = s + strlen(s); + while (--p >= s) { + if (*p == '.' && *fp.ext == '\0') + fp.ext = p; + else if (strchr(Prefix,*p)) { + q = p+1; + break; + } + } + + fp.dir = buf; + n = q - s; + strncpy(fp.dir,s,n); + fp.dir[n] = '\0'; + fp.name = buf + n + 1; + n = fp.ext - q; + strncpy(fp.name,q,n); + fp.name[n] = '\0'; + p = fp.ext; + fp.ext = fp.name + n + 1; + strcpy(fp.ext, p); + + return &fp; + } + +/* + * makename - make a file name, optionally substituting a new dir and/or ext + */ +char *makename(dest,d,name,e) +char *dest, *d, *name, *e; + { + struct fileparts fp; + fp = *fparse(name); + if (d != NULL) + fp.dir = d; + if (e != NULL) + fp.ext = e; + sprintf(dest,"%s%s%s",fp.dir,fp.name,fp.ext); + return dest; + } + +/* + * smatch - case-insensitive string match - returns nonzero if they match + */ +int smatch(s,t) +char *s, *t; + { + char a, b; + for (;;) { + while (*s == *t) + if (*s++ == '\0') + return 1; + else + t++; + a = *s++; + b = *t++; + if (isupper(a)) a = tolower(a); + if (isupper(b)) b = tolower(b); + if (a != b) + return 0; + } + } + +#if MSWIN + +FILE *pathOpen(fname, mode) + char *fname; + char *mode; + { + char buf[MaxPath]; + int i; + + for (i = 0; fname[i] != '\0'; i++) { + if (fname[i] == '/' || fname[i] == ':' || fname[i] == '\\') { + /* fname contains an explicit path */ + return fopen(fname, mode); + } + } + + if (!pathfind(buf, getenv("PATH"), fname, NULL)) + return 0; + + return fopen(buf, mode); + } + +#endif /* MSWIN */ diff --git a/src/common/fixgram.icn b/src/common/fixgram.icn new file mode 100644 index 0000000..8d55b4d --- /dev/null +++ b/src/common/fixgram.icn @@ -0,0 +1,48 @@ +# fix grammar after it has been put through the C preprosesor +# +# allow at most 3 blank lines in a row +# change /*#...*/ to #... +# remove lines begining with # +# remove some of the extra tabs introduced by macro definitions and insert +# some newlines + +procedure main() + local s,n + + write("/*") + write(" * W A R N I N G:") + write(" *") + write(" * this file has been preprocessed") + write(" * any changes must be made to the original file") + write(" */") + write() + + n := 0 + while s := read() do { + while s == "" do { + if (n +:= 1) <= 3 then write() + s := read() | break + } + s ? (="/*#" & write("#",tab(find("*/"))) & (n := 0)) | + ="#" | + (fix_tabs() & (n := 0)) + } +end + +procedure fix_tabs() + if ="\t\t\t" then { + tab(many('\t')) + writes("\t\t") + } + while writes(tab(upto('{\t'))) do + if writes(="{") then + tab(many(' \t')) + else if ="\t\t\t" then { + writes("\n\t\t") + tab(many('\t')) + } + else + writes(tab(many('\t'))) + write(tab(0)) + return +end diff --git a/src/common/getopt.c b/src/common/getopt.c new file mode 100644 index 0000000..9b02f12 --- /dev/null +++ b/src/common/getopt.c @@ -0,0 +1,57 @@ +/* + * getopt.c -- get command-line options. + */ + +#include "../h/gsupport.h" + +#ifndef SysOpt +extern char* progname; + +/* + * Based on a public domain implementation of System V + * getopt(3) by Keith Bostic (keith@seismo), Aug 24, 1984. + */ + +#define BadCh (int)'?' +#define EMSG "" +#define tell(m) fprintf(stderr,"%s: %s -- %c\n",progname,m,optopt);return BadCh; + +int optind = 1; /* index into parent argv vector */ +int optopt; /* character checked for validity */ +char *optarg; /* argument associated with option */ + +int getopt(int nargc, char *const nargv[], const char *ostr) + { + static char *place = EMSG; /* option letter processing */ + register char *oli; /* option letter list index */ + + if(!*place) { /* update scanning pointer */ + if(optind >= nargc || *(place = nargv[optind]) != '-' || !*++place) + return EOF; + if (*place == '-') { /* found "--" */ + ++optind; + return EOF; + } + } /* option letter okay? */ + + if (((optopt=(int)*place++) == (int)':') || (oli=strchr(ostr,optopt)) == 0) { + if(!*place) ++optind; + tell("illegal option"); + } + if (*++oli != ':') { /* don't need argument */ + optarg = NULL; + if (!*place) ++optind; + } + else { /* need an argument */ + if (*place) optarg = place; /* no white space */ + else if (nargc <= ++optind) { /* no arg */ + place = EMSG; + tell("option requires an argument"); + } + else optarg = nargv[optind]; /* white space */ + place = EMSG; + ++optind; + } + return optopt; /* dump back option letter */ + } +#endif /* SysOpt */ diff --git a/src/common/icontype.h b/src/common/icontype.h new file mode 100644 index 0000000..38a1d70 --- /dev/null +++ b/src/common/icontype.h @@ -0,0 +1,55 @@ +/* + * This file was generated by the program typespec. + */ + +int str_typ = 0; +int int_typ = 1; +int rec_typ = 2; +int proc_typ = 3; +int coexp_typ = 4; +int stv_typ = 5; +int ttv_typ = 6; +int null_typ = 7; +int cset_typ = 8; +int real_typ = 9; +int list_typ = 10; +int tbl_typ = 11; + +int num_typs = 20; +struct icon_type icontypes[20] = { + {"string", 0, DrfNone, TRetSpcl, NULL, 0, 0, "s", "String"}, + {"integer", 0, DrfNone, TRetNone, NULL, 0, 0, "i", "Integer"}, + {"record", 0, DrfNone, TRetBlkP, NULL, 0, 0, "R", "Record"}, + {"proc", 0, DrfNone, TRetBlkP, NULL, 0, 0, "proc", "Proc"}, + {"coexpr", 0, DrfNone, TRetBlkP, NULL, 0, 0, "C", "Coexpr"}, + {"tvsubs", 1, DrfSpcl, TRetSpcl, NULL, 1, 0, "sstv", "Tvsubs"}, + {"tvtbl", 1, DrfSpcl, TRetBlkP, NULL, 1, 1, "tetv", "Tvtbl"}, + {"null", 0, DrfNone, TRetNone, NULL, 0, 0, "n", "Null"}, + {"cset", 0, DrfNone, TRetBlkP, NULL, 0, 0, "c", "Cset"}, + {"real", 0, DrfNone, TRetBlkP, NULL, 0, 0, "r", "Real"}, + {"list", 1, DrfNone, TRetBlkP, NULL, 1, 2, "L", "List"}, + {"table", 1, DrfNone, TRetBlkP, NULL, 3, 3, "T", "Table"}, + {"file", 0, DrfNone, TRetBlkP, NULL, 0, 0, "f", "File"}, + {"set", 1, DrfNone, TRetBlkP, NULL, 1, 6, "S", "Set"}, + {"kywdint", 0, DrfCnst, TRetDescP, ".i..................", 0, 0, "kywdint", "Kywdint"}, + {"kywdsubj", 0, DrfCnst, TRetDescP, "s...................", 0, 0, "kywdsubj", "Kywdsubj"}, + {"kywdpos", 0, DrfCnst, TRetDescP, ".i..................", 0, 0, "kywdpos", "Kywdpos"}, + {"kywdevent", 0, DrfCnst, TRetDescP, "siRpC..ncrLTfS......", 0, 0, "kywdevent", "Kywdevent"}, + {"kywdwin", 0, DrfCnst, TRetDescP, ".......n....f.......", 0, 0, "kywdwin", "Kywdwin"}, + {"kywdstr", 0, DrfCnst, TRetDescP, "s...................", 0, 0, "kywdstr", "Kywdstr"}}; + +int str_var = 0; +int trpd_tbl = 1; +int lst_elem = 2; +int tbl_dflt = 5; +int tbl_val = 4; + +int num_cmpnts = 7; +struct typ_compnt typecompnt[7] = { + {"str_var", 0, 0, 5, NULL}, + {"trpd_tbl", 0, 0, 6, NULL}, + {"lst_elem", 0, 1, 10, "LE"}, + {"tbl_key", 0, 0, 11, NULL}, + {"tbl_val", 1, 1, 11, "TV"}, + {"tbl_dflt", 2, 0, 11, NULL}, + {"set_elem", 0, 0, 13, NULL}}; diff --git a/src/common/identify.c b/src/common/identify.c new file mode 100644 index 0000000..a1b7038 --- /dev/null +++ b/src/common/identify.c @@ -0,0 +1,30 @@ +#include "../h/gsupport.h" + +#undef COMPILER +#define COMPILER 1 /* insure compiler Version number */ +#include "../h/version.h" + +extern char *progname; + +/* + * id_comment - output a comment C identifying the date and time and what + * program is producing the output. + */ +void id_comment(f) +FILE *f; + { + static char sbuf[26]; + static int first_time = 1; + time_t ct; + + if (first_time) { + time(&ct); + strcpy(sbuf, ctime(&ct)); + first_time = 0; + } + fprintf(f, "/*\n"); + fprintf(f, " * %s", sbuf); + fprintf(f, " * This file was produced by\n"); + fprintf(f, " * %s: %s\n", progname, Version); + fprintf(f, " */\n"); + } diff --git a/src/common/infer.c b/src/common/infer.c new file mode 100644 index 0000000..819bf8b --- /dev/null +++ b/src/common/infer.c @@ -0,0 +1,33 @@ +/* + * infer.c -- generate definitions reflecting present hardware architecture + * + * Inspired by mail from Christian Hudon. + */ + +#include +#include +#include + +typedef struct { + char c; + double d; + } tstruct; + +static long atdepth(int n) { + return n <= 1 ? (long)&n : atdepth(n - 1); + } + +int main(int argc, char *argv[]) { + assert (-1 == (signed char)0xFF); /* chars must be 8 bits */ + assert (sizeof(void*) == sizeof(long)); /* these must be the same */ + assert (sizeof(int) >= 4); /* need 32-bit ints or better */ + assert (sizeof(long) <= 8); /* but can't handle over 64 */ + printf("/* generated by infer.c */\n"); + printf("#define IntBits %d\n", 8 * sizeof(int)); + printf("#define WordBits %d\n", 8 * sizeof(void *)); + if (offsetof(tstruct, d) > sizeof(void *)) + printf("#define Double\n"); + if (atdepth(2) > atdepth(1)) + printf("#define UpStack\n"); + return 0; + } diff --git a/src/common/ipp.c b/src/common/ipp.c new file mode 100644 index 0000000..8913ee5 --- /dev/null +++ b/src/common/ipp.c @@ -0,0 +1,971 @@ +/* + * ipp.c -- the Icon preprocessor. + * + * All Icon source passes through here before translation or compilation. + * Directives recognized are: + * #line n [filename] + * $line n [filename] + * $include filename + * $define identifier text + * $undef identifier + * $ifdef identifier + * $ifndef identifier + * $else + * $endif + * $error [text] + * + * Entry points are + * ppinit(fname,inclpath,m4flag) -- open input file + * ppdef(s,v) -- "$define s v", or "$undef s" if v is a null pointer + * ppch() -- return next preprocessed character + * ppecho() -- preprocess to stdout (for icont/iconc -E) + * + * See ../h/features.h for the set of predefined symbols. + */ + +#include "../h/gsupport.h" + +#define HTBINS 256 /* number of hash bins */ + +typedef struct fstruct { /* input file structure */ + struct fstruct *prev; /* previous file */ + char *fname; /* file name */ + long lno; /* line number */ + FILE *fp; /* stdio file pointer */ + int m4flag; /* nz if preprocessed by m4 */ + int ifdepth; /* $if nesting depth when opened */ + } infile; + +typedef struct bstruct { /* buffer pointer structure */ + struct bstruct *prev; /* previous pointer structure */ + struct cd *defn; /* definition being processed */ + char *ptr; /* saved pointer value */ + char *stop; /* saved stop value */ + char *lim; /* saved limit value */ + } buffer; + +typedef struct { /* preprocessor token structure */ + char *addr; /* beginning of token */ + short len; /* length */ + } ptok; + +typedef struct cd { /* structure holding a definition */ + struct cd *next; /* link to next defn */ + struct cd *prev; /* link to previous defn */ + short nlen, vlen; /* length of name & val */ + char inuse; /* nonzero if curr being expanded */ + char s[1]; /* name then value, as needed, no \0 */ + } cdefn; + +static int ppopen (char *fname, int m4); +static FILE * m4pipe (char *fname); +static char * rline (FILE *fp); +static void pushdef (cdefn *d); +static void pushline (char *fname, long lno); +static void ppdir (char *line); +static void pfatal (char *s1, char *s2); +static void skipcode (int doelse, int report); +static char * define (char *s); +static char * undef (char *s); +static char * ifdef (char *s); +static char * ifndef (char *s); +static char * ifxdef (char *s, int f); +static char * elsedir (char *s); +static char * endif (char *s); +static char * errdir (char *s); +static char * include (char *s); +static char * setline (char *s); +static char * wskip (char *s); +static char * nskip (char *s); +static char * matchq (char *s); +static char * getidt (char *dst, char *src); +static char * getfnm (char *dst, char *src); +static cdefn * dlookup (char *name, int len, char *val); + +struct ppcmd { + char *name; + char *(*func)(); + } +pplist[] = { + { "define", define }, + { "undef", undef }, + { "ifdef", ifdef }, + { "ifndef", ifndef }, + { "else", elsedir }, + { "endif", endif }, + { "include", include }, + { "line", setline }, + { "error", errdir }, + { 0, 0 }}; + +static infile nofile; /* ancestor of all files; all zero */ +static infile *curfile; /* pointer to current entry */ + +static buffer *bstack; /* stack of pending buffers */ +static buffer *bfree; /* pool of free bstructs */ + +static char *buf; /* input line buffer */ +static char *bnxt; /* next character */ +static char *bstop; /* limit of preprocessed chars */ +static char *blim; /* limit of all chars */ + +static cdefn *cbin[HTBINS]; /* hash bins for defn table */ + +static char *lpath; /* LPATH for finding source files */ + +static int ifdepth; /* depth of $if nesting */ + +extern int tfatals, nocode; /* provided by icont, iconc */ + +/* + * ppinit(fname, inclpath, m4) -- initialize preprocessor to read from fname. + * + * Returns 1 if successful, 0 if open failed. + */ +int ppinit(fname, inclpath, m4) +char *fname; +char *inclpath; +int m4; + { + int i; + cdefn *d, *n; + + /* + * clear out any existing definitions from previous files + */ + for (i = 0; i < HTBINS; i++) { + for (d = cbin[i]; d != NULL; d = n) { + n = d->next; + free((char *)d); + } + cbin[i] = NULL; + } + + /* + * install predefined symbols + */ +#define Feature(guard,symname,kwval) dlookup(symname, -1, "1"); +#include "../h/features.h" + + /* + * initialize variables and open source file + */ + lpath = inclpath; + curfile = &nofile; /* init file struct pointer */ + return ppopen(fname, m4); /* open main source file */ + } + +/* + * ppopen(fname, m4) -- open a new file for reading by the preprocessor. + * + * Returns 1 if successful, 0 if open failed. + * + * Open calls may be nested. Files are closed when EOF is read. + */ +static int ppopen(fname, m4) +char *fname; +int m4; + { + FILE *f; + infile *fs; + + for (fs = curfile; fs->fname != NULL; fs = fs->prev) + if (strcmp(fname, fs->fname) == 0) { + pfatal("circular include", fname); /* issue error message */ + return 1; /* treat as success */ + } + if (m4) + f = m4pipe(fname); + else if (curfile == &nofile && strcmp(fname, "-") == 0) { /* 1st file only */ + f = stdin; + fname = "stdin"; + } + else + f = fopen(fname, "r"); + if (f == NULL) { + return 0; + } + fs = alloc(sizeof(infile)); + fs->prev = curfile; + fs->fp = f; + fs->fname = salloc(fname); + fs->lno = 0; + fs->m4flag = m4; + fs->ifdepth = ifdepth; + pushline(fs->fname, 0L); + curfile = fs; + return 1; + } + +/* + * m4pipe -- open a pipe from m4. + */ +static FILE *m4pipe(filename) +char *filename; + { + FILE *f; + char *s = alloc(4 + strlen(filename)); + sprintf(s, "m4 %s", filename); + f = popen(s, "r"); + free(s); + return f; + } + +/* + * ppdef(s,v) -- define/undefine a symbol + * + * If v is a null pointer, undefines symbol s. + * Otherwise, defines s to have the value v. + * No error is given for a redefinition. + */ +void ppdef(s, v) +char *s, *v; + { + dlookup(s, -1, (char *)NULL); + if (v != NULL) + dlookup(s, -1, v); + } + +/* + * ppecho() -- run input through preprocessor and echo directly to stdout. + */ +void ppecho() + { + int c; + + while ((c = ppch()) != EOF) + putchar(c); + } + +/* + * ppch() -- get preprocessed character. + */ +int ppch() + { + int c, f; + char *p; + buffer *b; + cdefn *d; + infile *fs; + + for (;;) { + if (bnxt < bstop) /* if characters ready to go */ + return ((int)*bnxt++) & 0xFF; /* return first one */ + + if (bnxt < blim) { + /* + * There are characters in the buffer, but they haven't been + * checked for substitutions yet. Process either one id, if + * that's what's next, or as much else as we can. + */ + f = *bnxt; + if (isalpha(f) || f == '_') { + /* + * This is the first character of an identifier. It could + * be the name of a definition. If so, the name will be + * contiguous in this buffer. Check it. + */ + p = bnxt + 1; + while (p < blim && (isalnum(c = *p) || c == '_')) /* find end */ + p++; + bstop = p; /* safe to consume through end */ + if (((d = dlookup(bnxt, p-bnxt, bnxt)) == 0) || (d->inuse == 1)) { + bnxt++; + return f; /* not defined; just use it */ + } + /* + * We got a match. Remove the token from the input stream and + * push the replacement value. + */ + bnxt = p; + pushdef(d); /* make defn the curr buffer */ + continue; /* loop to preprocess */ + } + else { + /* + * Not an id. Find the end of non-id stuff and mark it as + * having been preprocessed. This is where we skip over + * string and cset literals to avoid processing them. + */ + p = bnxt++; + while (p < blim) { + c = *p; + if (isalpha(c) || c == '_') { /* there's an id ahead */ + bstop = p; + return f; + } + else if (isdigit(c)) { /* numeric constant */ + p = nskip(p); + } + else if (c == '#') { /* comment: skip to EOL */ + bstop = blim; + return f; + } + else if (c == '"' || c == '\''){ /* quoted literal */ + p = matchq(p); /* skip to end */ + if (*p != '\0') + p++; + } + else + p++; /* else advance one char */ + } + bstop = blim; /* mark end of processed chrs */ + return f; /* return first char */ + } + } + + /* + * The buffer is empty. Revert to a previous buffer. + */ + if (bstack != NULL) { + b = bstack; + b->defn->inuse = 0; + bnxt = b->ptr; + bstop = b->stop; + blim = b->lim; + bstack = b->prev; + b->prev = bfree; + bfree = b; + continue; /* loop to preprocess */ + } + + /* + * There's nothing at all in memory. Read a new line. + */ + if ((buf = rline(curfile->fp)) != NULL) { + /* + * The read was successful. + */ + p = bnxt = bstop = blim = buf; /* reset buffer pointers */ + curfile->lno++; /* bump line number */ + while (isspace(c = *p)) + p++; /* find first nonwhite */ + if (c == '$' && (!ispunct(p[1]) || p[1]==' ')) + ppdir(p + 1); /* handle preprocessor cmd */ + else if (buf[1]=='l' && buf[2]=='i' && buf[3]=='n' && buf[4]=='e' && + buf[0]=='#' && buf[5]==' ') + ppdir(p + 1); /* handle #line form */ + else { + /* + * Not a preprocessor line; will need to scan for symbols. + */ + bnxt = buf; + blim = buf + strlen(buf); + bstop = bnxt; /* no chars scanned yet */ + } + } + + else { + /* + * The read hit EOF. + */ + if (curfile->ifdepth != ifdepth) { + pfatal("unterminated $if", (char *)0); + ifdepth = curfile->ifdepth; + } + + /* + * switch to previous file and close current file. + */ + fs = curfile; + curfile = fs->prev; + + if (fs->m4flag) { /* if m4 preprocessing */ + void quit(); + if (pclose(fs->fp) != 0) /* close pipe */ + quit("m4 terminated abnormally"); + } + else + fclose(fs->fp); /* close current file */ + + free((char *)fs->fname); + free((char *)fs); + if (curfile == &nofile) /* if at outer level, return EOF */ + return EOF; + else /* else generate #line comment */ + pushline(curfile->fname, curfile->lno); + } + } + } + +/* + * rline(fp) -- read arbitrarily long line and return pointer. + * + * Allocates memory as needed. Returns NULL for EOF. Lines end with "\n\0". + */ +static char *rline(fp) +FILE *fp; + { +#define LINE_SIZE_INIT 100 +#define LINE_SIZE_INCR 100 + static char *lbuf = NULL; /* line buffer */ + static int llen = 0; /* current buffer length */ + register char *p; + register int c, n; + + /* if first time, allocate buffer */ + if (!lbuf) { + lbuf = alloc(LINE_SIZE_INIT); + llen = LINE_SIZE_INIT; + } + + /* first character is special; return NULL if hit EOF here */ + c = getc(fp); + if (c == EOF) + return NULL; + if (c == '\n') + return "\n"; + + p = lbuf; + n = llen - 3; + *p++ = c; + + for (;;) { + /* read until buffer full; return after newline or EOF */ + while (--n >= 0 && (c = getc(fp)) != '\n' && c != EOF) + *p++ = c; + if (n >= 0) { + *p++ = '\n'; /* always terminate with \n\0 */ + *p++ = '\0'; + return lbuf; + } + + /* need to read more, so we need a bigger buffer */ + llen += LINE_SIZE_INCR; + lbuf = realloc(lbuf, (unsigned int)llen); + if (!lbuf) { + fprintf(stderr, "rline(%d): out of memory\n", llen); + exit(EXIT_FAILURE); + } + p = lbuf + llen - LINE_SIZE_INCR - 2; + n = LINE_SIZE_INCR; + } + } + +/* + * pushdef(d) -- insert definition into the input stream. + */ +static void pushdef(d) +cdefn *d; + { + buffer *b; + + d->inuse = 1; + b = bfree; + if (b == NULL) + b = (buffer *)alloc(sizeof(buffer)); + else + bfree = b->prev; + b->prev = bstack; + b->defn = d; + b->ptr = bnxt; + b->stop = bstop; + b->lim = blim; + bstack = b; + bnxt = bstop = d->s + d->nlen; + blim = bnxt + d->vlen; + } + +/* + * pushline(fname,lno) -- push #line directive into input stream. + */ +static void pushline(fname, lno) +char *fname; +long lno; + { + static char tbuf[200]; + + sprintf(tbuf, "#line %ld \"%s\"\n", lno, fname); + bnxt = tbuf; + bstop = blim = tbuf + strlen(tbuf); + } + +/* + * ppdir(s) -- handle preprocessing directive. + * + * s is the portion of the line following the $. + */ +static void ppdir(s) +char *s; + { + char b0, *cmd, *errmsg; + struct ppcmd *p; + + b0 = buf[0]; /* remember first char of line */ + bnxt = "\n"; /* set buffer pointers to empty line */ + bstop = blim = bnxt + 1; + + s = wskip(s); /* skip whitespace */ + s = getidt(cmd = s - 1, s); /* get command name */ + s = wskip(s); /* skip whitespace */ + + for (p = pplist; p->name != NULL; p++) /* find name in table */ + if (strcmp(cmd, p->name) == 0) { + errmsg = (*p->func)(s); /* process directive */ + if (errmsg != NULL && (p->func != setline || b0 != '#')) + pfatal(errmsg, (char *)0); /* issue err if not from #line form */ + return; + } + + pfatal("invalid preprocessing directive", cmd); + } + +/* + * pfatal(s1,s2) -- output a preprocessing error message. + * + * s1 is the error message; s2 is the offending value, if any. + * If s2 ends in a newline, the newline is truncated in place. + * + * We can't use tfatal() because we have our own line counter which may be + * out of sync with the lexical analyzer's. + */ +static void pfatal(s1, s2) +char *s1, *s2; + { + int n; + + fprintf(stderr, "File %s; Line %ld # ", curfile->fname, curfile->lno); + if (s2 != NULL && *s2 != '\0') { + n = strlen(s2); + if (n > 0 && s2[n-1] == '\n') + s2[n-1] = '\0'; /* remove newline */ + fprintf(stderr, "\"%s\": ", s2); /* print offending value */ + } + fprintf(stderr, "%s\n", s1); /* print diagnostic */ + tfatals++; + nocode++; + } + +/* + * errdir(s) -- handle deliberate $error. + */ +static char *errdir(s) +char *s; + { + pfatal("explicit $error", s); /* issue msg with text */ + return NULL; + } + +/* + * define(s) -- handle $define directive. + */ +static char *define(s) +char *s; + { + char c, *name, *val; + + if (isalpha(c = *s) || c == '_') + s = getidt(name = s - 1, s); /* get name */ + else + return "$define: missing name"; + if (*s == '(') + return "$define: \"(\" after name requires preceding space"; + val = s = wskip(s); + if (*s != '\0') { + while ((c = *s) != '\0' && c != '#') { /* scan value */ + if (c == '"' || c == '\'') { + s = matchq(s); + if (*s == '\0') + return "$define: unterminated literal"; + } + s++; + } + while (isspace(s[-1])) /* trim trailing whitespace */ + s--; + } + *s = '\0'; + dlookup(name, -1, val); /* install in table */ + return NULL; + } + +/* + * undef(s) -- handle $undef directive. + */ +static char *undef(s) +char *s; + { + char c, *name; + + if (isalpha(c = *s) || c == '_') + s = getidt(name = s - 1, s); /* get name */ + else + return "$undef: missing name"; + if (*wskip(s) != '\0') + return "$undef: too many arguments"; + dlookup(name, -1, (char *)NULL); + return NULL; + } + +/* + * include(s) -- handle $include directive. + */ +static char *include(s) +char *s; + { + char *fname; + char fullpath[MaxPath]; + + s = getfnm(fname = s - 1, s); + if (*fname == '\0') + return "$include: invalid file name"; + if (*wskip(s) != '\0') + return "$include: too many arguments"; + if (!pathfind(fullpath, lpath, fname, (char *)NULL) || !ppopen(fullpath, 0)) + pfatal("cannot open", fname); + return NULL; + } + +/* + * setline(s) -- handle $line (or #line) directive. + */ +static char *setline(s) +char *s; + { + long n; + char c; + char *fname; + + if (!isdigit(c = *s)) + return "$line: no line number"; + n = c - '0'; + + while (isdigit(c = *++s)) /* extract line number */ + n = 10 * n + c - '0'; + s = wskip(s); /* skip whitespace */ + + if (isalpha (c = *s) || c == '_' || c == '"') { /* if filename */ + s = getfnm(fname = s - 1, s); /* extract it */ + if (*fname == '\0') + return "$line: invalid file name"; + } + else + fname = NULL; + + if (*wskip(s) != '\0') + return "$line: too many arguments"; + + curfile->lno = n; /* set line number */ + if (fname != NULL) { /* also set filename if given */ + free(curfile->fname); + curfile->fname = salloc(fname); + } + + pushline(curfile->fname, curfile->lno); + return NULL; + } + +/* + * ifdef(s), ifndef(s) -- conditional processing if s is/isn't defined. + */ +static char *ifdef(s) +char *s; + { + return ifxdef(s, 1); + } + +static char *ifndef(s) +char *s; + { + return ifxdef(s, 0); + } + +/* + * ifxdef(s) -- handle $ifdef (if n is 1) or $ifndef (if n is 0). + */ +static char *ifxdef(s, f) +char *s; +int f; + { + char c, *name; + + ifdepth++; + if (isalpha(c = *s) || c == '_') + s = getidt(name = s - 1, s); /* get name */ + else + return "$ifdef/$ifndef: missing name"; + if (*wskip(s) != '\0') + return "$ifdef/$ifndef: too many arguments"; + if ((dlookup(name, -1, name) != NULL) ^ f) + skipcode(1, 1); /* skip to $else or $endif */ + return NULL; + } + +/* + * elsedir(s) -- handle $else by skipping to $endif. + */ +static char *elsedir(s) +char *s; + { + if (ifdepth <= curfile->ifdepth) + return "unexpected $else"; + if (*s != '\0') + pfatal ("extraneous arguments on $else/$endif", s); + skipcode(0, 1); /* skip the $else section */ + return NULL; + } + +/* + * endif(s) -- handle $endif. + */ +static char *endif(s) +char *s; + { + if (ifdepth <= curfile->ifdepth) + return "unexpected $endif"; + if (*s != '\0') + pfatal ("extraneous arguments on $else/$endif", s); + ifdepth--; + return NULL; + } + +/* + * skipcode(doelse,report) -- skip code to $else (doelse=1) or $endif (=0). + * + * If report is nonzero, generate #line directive at end of skip. + */ +static void skipcode(doelse, report) +int doelse, report; + { + char c, *p, *cmd; + + while ((p = buf = rline(curfile->fp)) != NULL) { + curfile->lno++; /* bump line number */ + + /* + * Handle #line form encountered while skipping. + */ + if (buf[1]=='l' && buf[2]=='i' && buf[3]=='n' && buf[4]=='e' && + buf[0]=='#' && buf[5]==' ') { + ppdir(buf + 1); /* interpret #line */ + continue; + } + + /* + * Check for any other kind of preprocessing directive. + */ + while (isspace(c = *p)) + p++; /* find first nonwhite */ + if (c != '$' || (ispunct(p[1]) && p[1]!=' ')) + continue; /* not a preprocessing directive */ + p = wskip(p+1); /* skip whitespace */ + p = getidt(cmd = p-1, p); /* get command name */ + p = wskip(p); /* skip whitespace */ + + /* + * Check for a directive that needs special attention. + * Deliberately accept any form of $if... as valid + * in anticipation of possible future extensions; + * this allows them to appear here if commented out. + */ + if (cmd[0] == 'i' && cmd[1] == 'f') { + ifdepth++; + skipcode(0, 0); /* skip to $endif */ + } + else if (strcmp(cmd, "line") == 0) + setline(p); /* process $line, ignore errors */ + else if (strcmp(cmd, "endif") == 0 || + (doelse == 1 && strcmp(cmd, "else") == 0)) { + /* + * Time to stop skipping. + */ + if (*p != '\0') + pfatal ("extraneous arguments on $else/$endif", p); + if (cmd[1] == 'n') /* if $endif */ + ifdepth--; + if (report) + pushline(curfile->fname, curfile->lno); + return; + } + } + + /* + * At EOF, just return; main loop will report unterminated $if. + */ + } + +/* + * Token scanning functions. + */ + +/* + * wskip(s) -- skip whitespace and return updated pointer + * + * If '#' is encountered, skips to end of string. + */ +static char *wskip(s) +char *s; + { + char c; + + while (isspace(c = *s)) + s++; + if (c == '#') + while ((c = *++s) != 0) + ; + return s; + } + +/* + * nskip(s) -- skip over numeric constant and return updated pointer. + */ +static char *nskip(s) +char *s; + { + char c; + + while (isdigit(c = *++s)) + ; + if (c == 'r' || c == 'R') { + while (isalnum(c = *++s)) + ; + return s; + } + if (c == '.') + while (isdigit (c = *++s)) + ; + if (c == 'e' || c == 'E') { + c = s[1]; + if (c == '+' || c == '-') + s++; + while (isdigit (c = *++s)) + ; + } + return s; + } + +/* + * matchq(s) -- scan for matching quote character and return pointer. + * + * Taking *s as the quote character, s is incremented until it points + * to either another occurrence of the character or the '\0' terminating + * the string. Escaped quote characters do not stop the scan. The + * updated pointer is returned. + */ +static char *matchq(s) +char *s; + { + char c, q; + + q = *s; + if (q == '\0') + return s; + while ((c = *++s) != q && c != '\0') { + if (c == '\\') + if (*++s == '\0') + return s; + } + return s; + } + +/* + * getidt(dst,src) -- extract identifier, return updated pointer + * + * The identifier (in Icon terms, "many(&letters++&digits++'_')") + * at src is copied to dst and '\0' is appended. A pointer to the + * character following the identifier is returned. + * + * dst may partially overlap src if dst has a lower address. This + * is typically done to avoid the need for another arbitrarily-long + * buffer. An offset of -1 allows room for insertion of the '\0'. + */ +static char *getidt(dst, src) +char *dst, *src; + { + char c; + + while (isalnum(c = *src) || (c == '_')) { + *dst++ = c; + src++; + } + *dst = '\0'; + return src; + } + +/* + * getfnm(dst,src) -- extract filename, return updated pointer + * + * Similarly to getidt, getfnm extracts a quoted or unquoted file name. + * An empty string at dst indicates a missing or unterminated file name. + */ +static char *getfnm(dst, src) +char *dst, *src; + { + char *lim; + + if (*src != '"') + return getidt(dst, src); + lim = matchq(src); + if (*lim != '"') { + *dst = '\0'; + return lim; + } + while (++src < lim) + if ((*dst++ = *src) == '\\') + dst[-1] = *++src; + *dst = '\0'; + return lim + 1; + } + +/* + * dlookup(name, len, val) look up entry in definition table. + * + * If val == name, return the existing value, or NULL if undefined. + * If val == NULL, delete any existing value and undefine the name. + * If val != NULL, install a new value, and print error if different. + * + * If name is null, the call is ignored. + * If len < 0, strlen(name) is taken. + */ +static cdefn *dlookup(name, len, val) +char *name; +int len; +char *val; + { + int h, i, nlen, vlen; + unsigned int t; + cdefn *d, **p; + + if (len < 0) + len = strlen(name); + if (len == 0) + return NULL; + for (t = i = 0; i < len; i++) + t = 37 * t + (name[i] & 0xFF); /* calc hash value */ + h = t % HTBINS; /* calc bin number */ + p = &cbin[h]; /* get head of list */ + while ((d = *p) != NULL) { + if (d->nlen == len && strncmp(name, d->s, len) == 0) { + /* + * We found a match in the table. + */ + if (val == NULL) { /* if $undef */ + *p = d->next; /* delete from table */ + free((char *)d); + return NULL; + } + if (val != name && strcmp(val, d->s + d->nlen) != 0) + pfatal("value redefined", name); + return d; /* return pointer to entry */ + } + p = &d->next; + } + /* + * No match. Install a definition if that is what is wanted. + */ + if (val == name || val == NULL) /* if was reference or $undef */ + return NULL; + nlen = strlen(name); + vlen = strlen(val); + d = (cdefn *)alloc(sizeof(*d) - sizeof(d->s) + nlen + vlen + 1); + d->nlen = nlen; + d->vlen = vlen; + d->inuse = 0; + strcpy(d->s, name); + strcpy(d->s + nlen, val); + d->prev = NULL; + d->next = cbin[h]; + if (d->next != NULL) + d->next->prev = d; + cbin[h] = d; + return d; + } diff --git a/src/common/lextab.h b/src/common/lextab.h new file mode 100644 index 0000000..7a6154b --- /dev/null +++ b/src/common/lextab.h @@ -0,0 +1,576 @@ +/* + * NOTE: this file is generated automatically by mktoktab + * from tokens.txt and op.txt. + */ + +/* + * Token table - contains an entry for each token type + * with printable name of token, token type, and flags + * for semicolon insertion. + */ + +struct toktab toktab[] = { +/* token token type flags */ + + /* primitives */ + "identifier", IDENT, Beginner+Ender, /* 0 */ + "integer-literal", INTLIT, Beginner+Ender, /* 1 */ + "real-literal", REALLIT, Beginner+Ender, /* 2 */ + "string-literal", STRINGLIT, Beginner+Ender, /* 3 */ + "cset-literal", CSETLIT, Beginner+Ender, /* 4 */ + "end-of-file", EOFX, 0, /* 5 */ + + /* reserved words */ + "break", BREAK, Beginner+Ender, /* 6 */ + "by", BY, 0, /* 7 */ + "case", CASE, Beginner, /* 8 */ + "create", CREATE, Beginner, /* 9 */ + "default", DEFAULT, Beginner, /* 10 */ + "do", DO, 0, /* 11 */ + "else", ELSE, 0, /* 12 */ + "end", END, Beginner, /* 13 */ + "every", EVERY, Beginner, /* 14 */ + "fail", FAIL, Beginner+Ender, /* 15 */ + "global", GLOBAL, 0, /* 16 */ + "if", IF, Beginner, /* 17 */ + "initial", INITIAL, Beginner, /* 18 */ + "invocable", INVOCABLE, 0, /* 19 */ + "link", LINK, 0, /* 20 */ + "local", LOCAL, Beginner, /* 21 */ + "next", NEXT, Beginner+Ender, /* 22 */ + "not", NOT, Beginner, /* 23 */ + "of", OF, 0, /* 24 */ + "procedure", PROCEDURE, 0, /* 25 */ + "record", RECORD, 0, /* 26 */ + "repeat", REPEAT, Beginner, /* 27 */ + "return", RETURN, Beginner+Ender, /* 28 */ + "static", STATIC, Beginner, /* 29 */ + "suspend", SUSPEND, Beginner+Ender, /* 30 */ + "then", THEN, 0, /* 31 */ + "to", TO, 0, /* 32 */ + "until", UNTIL, Beginner, /* 33 */ + "while", WHILE, Beginner, /* 34 */ + "end-of-file", 0, 0, + }; + +/* + * restab[c] points to the first reserved word in toktab which + * begins with the letter c. + */ + +struct toktab *restab[] = { + NULL, &toktab[ 6], &toktab[ 8], &toktab[10], /* 61-64 abcd */ + &toktab[12], &toktab[15], &toktab[16], NULL, /* 65-68 efgh */ + &toktab[17], NULL, NULL, &toktab[20], /* 69-6C ijkl */ + NULL, &toktab[22], &toktab[24], &toktab[25], /* 6D-70 mnop */ + NULL, &toktab[26], &toktab[29], &toktab[31], /* 71-74 qrst */ + &toktab[33], NULL, &toktab[34], NULL, /* 75-78 uvwx */ + NULL, NULL, /* 79-7A yz */ + }; + +/* + * The operator table acts to extend the token table, it + * indicates what implementations are expected from rtt, + * and it has pointers for the implementation information. + */ + +struct optab optab[] = { + {{"!", BANG, Beginner}, Unary, NULL, NULL}, /* 0 */ + {{"%", MOD, 0}, Binary, NULL, NULL}, /* 1 */ + {{"%:=", AUGMOD, 0}, 0, NULL, NULL}, /* 2 */ + {{"&", AND, Beginner}, Binary, NULL, NULL}, /* 3 */ + {{"&:=", AUGAND, 0}, 0, NULL, NULL}, /* 4 */ + {{"*", STAR, Beginner}, Unary | Binary, NULL, NULL}, /* 5 */ + {{"*:=", AUGSTAR, 0}, 0, NULL, NULL}, /* 6 */ + {{"**", INTER, Beginner}, Binary, NULL, NULL}, /* 7 */ + {{"**:=", AUGINTER, 0}, 0, NULL, NULL}, /* 8 */ + {{"+", PLUS, Beginner}, Unary | Binary, NULL, NULL}, /* 9 */ + {{"+:=", AUGPLUS, 0}, 0, NULL, NULL}, /* 10 */ + {{"++", UNION, Beginner}, Binary, NULL, NULL}, /* 11 */ + {{"++:=", AUGUNION, 0}, 0, NULL, NULL}, /* 12 */ + {{"-", MINUS, Beginner}, Unary | Binary, NULL, NULL}, /* 13 */ + {{"-:=", AUGMINUS, 0}, 0, NULL, NULL}, /* 14 */ + {{"--", DIFF, Beginner}, Binary, NULL, NULL}, /* 15 */ + {{"--:=", AUGDIFF, 0}, 0, NULL, NULL}, /* 16 */ + {{".", DOT, Beginner}, Unary, NULL, NULL}, /* 17 */ + {{"/", SLASH, Beginner}, Unary | Binary, NULL, NULL}, /* 18 */ + {{"/:=", AUGSLASH, 0}, 0, NULL, NULL}, /* 19 */ + {{":=", ASSIGN, 0}, Binary, NULL, NULL}, /* 20 */ + {{":=:", SWAP, 0}, Binary, NULL, NULL}, /* 21 */ + {{"<", NMLT, 0}, Binary, NULL, NULL}, /* 22 */ + {{"<:=", AUGNMLT, 0}, 0, NULL, NULL}, /* 23 */ + {{"<-", REVASSIGN, 0}, Binary, NULL, NULL}, /* 24 */ + {{"<->", REVSWAP, 0}, Binary, NULL, NULL}, /* 25 */ + {{"<<", SLT, 0}, Binary, NULL, NULL}, /* 26 */ + {{"<<:=", AUGSLT, 0}, 0, NULL, NULL}, /* 27 */ + {{"<<=", SLE, 0}, Binary, NULL, NULL}, /* 28 */ + {{"<<=:=", AUGSLE, 0}, 0, NULL, NULL}, /* 29 */ + {{"<=", NMLE, 0}, Binary, NULL, NULL}, /* 30 */ + {{"<=:=", AUGNMLE, 0}, 0, NULL, NULL}, /* 31 */ + {{"=", NMEQ, Beginner}, Unary | Binary, NULL, NULL}, /* 32 */ + {{"=:=", AUGNMEQ, 0}, 0, NULL, NULL}, /* 33 */ + {{"==", SEQ, Beginner}, Binary, NULL, NULL}, /* 34 */ + {{"==:=", AUGSEQ, 0}, 0, NULL, NULL}, /* 35 */ + {{"===", EQUIV, Beginner}, Binary, NULL, NULL}, /* 36 */ + {{"===:=", AUGEQUIV, 0}, 0, NULL, NULL}, /* 37 */ + {{">", NMGT, 0}, Binary, NULL, NULL}, /* 38 */ + {{">:=", AUGNMGT, 0}, 0, NULL, NULL}, /* 39 */ + {{">=", NMGE, 0}, Binary, NULL, NULL}, /* 40 */ + {{">=:=", AUGNMGE, 0}, 0, NULL, NULL}, /* 41 */ + {{">>", SGT, 0}, Binary, NULL, NULL}, /* 42 */ + {{">>:=", AUGSGT, 0}, 0, NULL, NULL}, /* 43 */ + {{">>=", SGE, 0}, Binary, NULL, NULL}, /* 44 */ + {{">>=:=", AUGSGE, 0}, 0, NULL, NULL}, /* 45 */ + {{"?", QMARK, Beginner}, Unary, NULL, NULL}, /* 46 */ + {{"?:=", AUGQMARK, 0}, 0, NULL, NULL}, /* 47 */ + {{"@", AT, Beginner}, 0, NULL, NULL}, /* 48 */ + {{"@:=", AUGAT, 0}, 0, NULL, NULL}, /* 49 */ + {{"\\", BACKSLASH, Beginner}, Unary, NULL, NULL}, /* 50 */ + {{"^", CARET, Beginner}, Unary | Binary, NULL, NULL}, /* 51 */ + {{"^:=", AUGCARET, 0}, 0, NULL, NULL}, /* 52 */ + {{"|", BAR, Beginner}, 0, NULL, NULL}, /* 53 */ + {{"||", CONCAT, Beginner}, Binary, NULL, NULL}, /* 54 */ + {{"||:=", AUGCONCAT, 0}, 0, NULL, NULL}, /* 55 */ + {{"|||", LCONCAT, Beginner}, Binary, NULL, NULL}, /* 56 */ + {{"|||:=", AUGLCONCAT, 0}, 0, NULL, NULL}, /* 57 */ + {{"~", TILDE, Beginner}, Unary, NULL, NULL}, /* 58 */ + {{"~=", NMNE, Beginner}, Binary, NULL, NULL}, /* 59 */ + {{"~=:=", AUGNMNE, 0}, 0, NULL, NULL}, /* 60 */ + {{"~==", SNE, Beginner}, Binary, NULL, NULL}, /* 61 */ + {{"~==:=", AUGSNE, 0}, 0, NULL, NULL}, /* 62 */ + {{"~===", NEQUIV, Beginner}, Binary, NULL, NULL}, /* 63 */ + {{"~===:=", AUGNEQUIV, 0}, 0, NULL, NULL}, /* 64 */ + {{"(", LPAREN, Beginner}, 0, NULL, NULL}, /* 65 */ + {{")", RPAREN, Ender}, 0, NULL, NULL}, /* 66 */ + {{"+:", PCOLON, 0}, 0, NULL, NULL}, /* 67 */ + {{",", COMMA, 0}, 0, NULL, NULL}, /* 68 */ + {{"-:", MCOLON, 0}, 0, NULL, NULL}, /* 69 */ + {{":", COLON, 0}, 0, NULL, NULL}, /* 70 */ + {{";", SEMICOL, 0}, 0, NULL, NULL}, /* 71 */ + {{"[", LBRACK, Beginner}, 0, NULL, NULL}, /* 72 */ + {{"]", RBRACK, Ender}, 0, NULL, NULL}, /* 73 */ + {{"{", LBRACE, Beginner}, 0, NULL, NULL}, /* 74 */ + {{"}", RBRACE, Ender}, 0, NULL, NULL}, /* 75 */ + {{"$(", LBRACE, Beginner}, 0, NULL, NULL}, /* 76 */ + {{"$)", RBRACE, Ender}, 0, NULL, NULL}, /* 77 */ + {{"$<", LBRACK, Beginner}, 0, NULL, NULL}, /* 78 */ + {{"$>", RBRACK, Ender}, 0, NULL, NULL}, /* 79 */ + {{NULL, 0, 0}, 0, NULL, NULL} + }; + +int asgn_loc = 20; +int semicol_loc = 71; +int plus_loc = 9; +int minus_loc = 13; + +/* + * getopr - find the longest legal operator and return the + * index to its entry in the operator table. + */ + +int getopr(ac, cc) +int ac; +int *cc; + { + register char c; + + *cc = ' '; + switch (c = ac) { + case '!': + return 0; /* ! */ + case '$': + switch (c = NextChar) { + case '(': + return 76; /* $( */ + case ')': + return 77; /* $) */ + case '<': + return 78; /* $< */ + case '>': + return 79; /* $> */ + } + break; + case '%': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 2; /* %:= */ + } + } + else { + *cc = c; + return 1; /* % */ + } + break; + case '&': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 4; /* &:= */ + } + } + else { + *cc = c; + return 3; /* & */ + } + break; + case '(': + return 65; /* ( */ + case ')': + return 66; /* ) */ + case '*': + switch (c = NextChar) { + case '*': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 8; /* **:= */ + } + } + else { + *cc = c; + return 7; /* ** */ + } + break; + case ':': + if ((c = NextChar) == '=') { + return 6; /* *:= */ + } + break; + default: + *cc = c; + return 5; /* * */ + } + break; + case '+': + switch (c = NextChar) { + case '+': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 12; /* ++:= */ + } + } + else { + *cc = c; + return 11; /* ++ */ + } + break; + case ':': + if ((c = NextChar) == '=') { + return 10; /* +:= */ + } + else { + *cc = c; + return 67; /* +: */ + } + default: + *cc = c; + return 9; /* + */ + } + break; + case ',': + return 68; /* , */ + case '-': + switch (c = NextChar) { + case '-': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 16; /* --:= */ + } + } + else { + *cc = c; + return 15; /* -- */ + } + break; + case ':': + if ((c = NextChar) == '=') { + return 14; /* -:= */ + } + else { + *cc = c; + return 69; /* -: */ + } + default: + *cc = c; + return 13; /* - */ + } + break; + case '.': + return 17; /* . */ + case '/': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 19; /* /:= */ + } + } + else { + *cc = c; + return 18; /* / */ + } + break; + case ':': + if ((c = NextChar) == '=') { + if ((c = NextChar) == ':') { + return 21; /* :=: */ + } + else { + *cc = c; + return 20; /* := */ + } + } + else { + *cc = c; + return 70; /* : */ + } + case ';': + return 71; /* ; */ + case '<': + switch (c = NextChar) { + case '-': + if ((c = NextChar) == '>') { + return 25; /* <-> */ + } + else { + *cc = c; + return 24; /* <- */ + } + case ':': + if ((c = NextChar) == '=') { + return 23; /* <:= */ + } + break; + case '<': + switch (c = NextChar) { + case ':': + if ((c = NextChar) == '=') { + return 27; /* <<:= */ + } + break; + case '=': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 29; /* <<=:= */ + } + } + else { + *cc = c; + return 28; /* <<= */ + } + break; + default: + *cc = c; + return 26; /* << */ + } + break; + case '=': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 31; /* <=:= */ + } + } + else { + *cc = c; + return 30; /* <= */ + } + break; + default: + *cc = c; + return 22; /* < */ + } + break; + case '=': + switch (c = NextChar) { + case ':': + if ((c = NextChar) == '=') { + return 33; /* =:= */ + } + break; + case '=': + switch (c = NextChar) { + case ':': + if ((c = NextChar) == '=') { + return 35; /* ==:= */ + } + break; + case '=': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 37; /* ===:= */ + } + } + else { + *cc = c; + return 36; /* === */ + } + break; + default: + *cc = c; + return 34; /* == */ + } + break; + default: + *cc = c; + return 32; /* = */ + } + break; + case '>': + switch (c = NextChar) { + case ':': + if ((c = NextChar) == '=') { + return 39; /* >:= */ + } + break; + case '=': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 41; /* >=:= */ + } + } + else { + *cc = c; + return 40; /* >= */ + } + break; + case '>': + switch (c = NextChar) { + case ':': + if ((c = NextChar) == '=') { + return 43; /* >>:= */ + } + break; + case '=': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 45; /* >>=:= */ + } + } + else { + *cc = c; + return 44; /* >>= */ + } + break; + default: + *cc = c; + return 42; /* >> */ + } + break; + default: + *cc = c; + return 38; /* > */ + } + break; + case '?': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 47; /* ?:= */ + } + } + else { + *cc = c; + return 46; /* ? */ + } + break; + case '@': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 49; /* @:= */ + } + } + else { + *cc = c; + return 48; /* @ */ + } + break; + case '[': + return 72; /* [ */ + case '\\': + return 50; /* \ */ + case ']': + return 73; /* ] */ + case '^': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 52; /* ^:= */ + } + } + else { + *cc = c; + return 51; /* ^ */ + } + break; + case '{': + return 74; /* { */ + case '|': + if ((c = NextChar) == '|') { + switch (c = NextChar) { + case ':': + if ((c = NextChar) == '=') { + return 55; /* ||:= */ + } + break; + case '|': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 57; /* |||:= */ + } + } + else { + *cc = c; + return 56; /* ||| */ + } + break; + default: + *cc = c; + return 54; /* || */ + } + } + else { + *cc = c; + return 53; /* | */ + } + break; + case '}': + return 75; /* } */ + case '~': + if ((c = NextChar) == '=') { + switch (c = NextChar) { + case ':': + if ((c = NextChar) == '=') { + return 60; /* ~=:= */ + } + break; + case '=': + switch (c = NextChar) { + case ':': + if ((c = NextChar) == '=') { + return 62; /* ~==:= */ + } + break; + case '=': + if ((c = NextChar) == ':') { + if ((c = NextChar) == '=') { + return 64; /* ~===:= */ + } + } + else { + *cc = c; + return 63; /* ~=== */ + } + break; + default: + *cc = c; + return 61; /* ~== */ + } + break; + default: + *cc = c; + return 59; /* ~= */ + } + } + else { + *cc = c; + return 58; /* ~ */ + } + break; + } + tfatal("invalid character", (char *)NULL); + return -1; + } diff --git a/src/common/literals.c b/src/common/literals.c new file mode 100644 index 0000000..4978d5f --- /dev/null +++ b/src/common/literals.c @@ -0,0 +1,180 @@ +#include "../h/gsupport.h" +#include "../h/esctab.h" + +/* + * Prototypes. + */ +unsigned short *bitvect (char *image, int len); +static int escape (char **str_ptr, int *nchars_ptr); + +/* + * Within translators, csets are internally implemented as a bit vector made + * from an array of unsigned shorts. For portability, only the lower 16 + * bits of these shorts are used. + */ +#define BVectIndx(c) (((unsigned char)c >> 4) & 0xf) +#define BitInShrt(c) (1 << ((unsigned char)c & 0xf)) + +/* + * Macros used by escape() to advance to the next character and to + * test the kind of character. + */ +#define NextChar(c) ((*nchars_ptr)--, c = *(*str_ptr)++) +#define isoctal(c) ((c)>='0'&&(c)<='7') /* macro to test for octal digit */ + +/* + * escape - translate the character sequence following a '\' into the + * single character it represents. + */ +static int escape(str_ptr, nchars_ptr) +char **str_ptr; +int *nchars_ptr; + { + register int c, nc, i; + + /* + * Note, it is impossible to have a character string ending with a '\', + * something must be here. + */ + NextChar(c); + if (isoctal(c)) { + /* + * translate an octal escape -- backslash followed by one, two, or three + * octal digits. + */ + c -= '0'; + for (i = 2; *nchars_ptr > 0 && isoctal(**str_ptr) && i <= 3; ++i) { + NextChar(nc); + c = (c << 3) | (nc - '0'); + } + return (c & 0377); + } + else if (c == 'x') { + /* + * translate a hexadecimal escape -- backslash-x followed by one or + * two hexadecimal digits. + */ + c = 0; + for (i = 1; *nchars_ptr > 0 && isxdigit(**str_ptr) && i <= 2; ++i) { + NextChar(nc); + if (nc >= 'a' && nc <= 'f') + nc -= 'a' - 10; + else if (nc >= 'A' && nc <= 'F') + nc -= 'A' - 10; + else if (isdigit(nc)) + nc -= '0'; + c = (c << 4) | nc; + } + return c; + } + else if (c == '^') { + /* + * translate a control escape -- backslash followed by caret and one + * character. + */ + if (*nchars_ptr <= 0) + return 0; /* could only happen in a keyword */ + NextChar(c); + return (c & 037); + } + else + return esctab[c]; + } + +/* + * bitvect - convert cset literal into a bitvector + */ +unsigned short *bitvect(image, len) +char *image; +int len; + { + register int c; + register unsigned short *bv; + register int i; + + bv = alloc(BVectSize * sizeof(unsigned short)); + for (i = 0; i < BVectSize; ++i) + bv[i] = 0; + while (len-- > 0) { + c = *image++; + if (c == '\\') + c = escape(&image, &len); + bv[BVectIndx(c)] |= BitInShrt(c); + } + return bv; + } + +/* + * cset_init - use bitvector for a cset to write an initialization for + * a cset block. + */ +void cset_init(f, bv) +FILE *f; +unsigned short *bv; + { + int size; + unsigned short n; + register int j; + + size = 0; + for (j = 0; j < BVectSize; ++j) + for (n = bv[j]; n != 0; n >>= 1) + size += n & 1; + fprintf(f, "{T_Cset, %d,\n", size); + fprintf(f, " cset_display(0x%x", bv[0]); + for (j = 1; j < BVectSize; ++j) + fprintf(f, ",0x%x", bv[j]); + fprintf(f, ")\n };\n"); + } + +/* + * prtstr - print an Icon string literal as a C string literal. + */ +int prt_i_str(f, s, len) +FILE *f; +char *s; +int len; + { + int c; + int n_chars; + + n_chars = 0; + while (len-- > 0) { + ++n_chars; + c = *s++; + if (c == '\\') + c = escape(&s, &len); + switch (c) { + case '\n': + fprintf(f, "\\n"); + break; + case '\t': + fprintf(f, "\\t"); + break; + case '\v': + fprintf(f, "\\v"); + break; + case '\b': + fprintf(f, "\\b"); + break; + case '\r': + fprintf(f, "\\r"); + break; + case '\f': + fprintf(f, "\\f"); + break; + case '\\': + fprintf(f, "\\\\"); + break; + case '\"': + fprintf(f, "\\\""); + break; + default: + if (isprint(c)) + fprintf(f, "%c", c); + else + fprintf(f, "\\%03o", (int)c); + } + } + return n_chars; + } diff --git a/src/common/long.c b/src/common/long.c new file mode 100644 index 0000000..071a944 --- /dev/null +++ b/src/common/long.c @@ -0,0 +1,34 @@ +/* + * long.c -- functions for handling long values on 16-bit computers. + */ + +#include "../h/gsupport.h" + +/* + * Write a long string in int-sized chunks. + */ + +long longwrite(s,len,file) +FILE *file; +char *s; +long len; +{ + long tally = 0; + int n = 0; + int leftover, loopnum; + char *p; + + leftover = (int)(len % (long)MaxInt); + for (p = s, loopnum = (int)(len / (long)MaxInt); loopnum; loopnum--) { + n = fwrite(p,sizeof(char),MaxInt,file); + tally += (long)n; + p += MaxInt; + } + if (leftover) { + n = fwrite(p,sizeof(char),leftover,file); + tally += (long)n; + } + if (tally != len) + return -1; + else return tally; + } diff --git a/src/common/mktoktab.icn b/src/common/mktoktab.icn new file mode 100644 index 0000000..c066958 --- /dev/null +++ b/src/common/mktoktab.icn @@ -0,0 +1,507 @@ +# Build the files: +# lextab.h - token tables and operator recognizer +# yacctok.h - %token declarations for YACC +# from token description file "tokens.txt" and operator description +# file "op.txt". + +global token, tokval, bflag, eflag, head, oper, tail, count +global restable, flagtable, op_lst, asgn_loc, semicol_loc, plus_loc, minus_loc +global white_sp, unary_set +global tokfile, opfile, toktab, tok_dot_h + +record op_sym(op, aug, tokval, unary, binary) +record association(op, n) +record trie(by_1st_c, dflt) + +procedure tokpat() + if tab(many(white_sp)) & (token := tab(upto(white_sp))) & + tab(many(white_sp)) & (tokval := (tab(upto(white_sp) | 0))) + then return (tab(upto('b')) & (bflag := move(1))) | (bflag := "") & + ((tab(upto('e')) & (eflag := move(1))) | (eflag := "")) & pos(0) +end + +procedure main() + local line, letter, lastletter + local s, op, aug, tok, unary, binary, tok_chars, sym, op_trie + local prognm, tokfnm, opfnm, toktbnm, dothnm, op_linenum + + white_sp := ' \t' + + prognm := "mktoktab" + tokfnm := "tokens.txt" + opfnm := "op.txt" + toktbnm := "lextab.h" + dothnm := "yacctok.h" + + restable := table() + flagtable := table("") + flagtable[""] := "0" + flagtable["b"] := "Beginner" + flagtable["e"] := "Ender" + flagtable["be"] := "Beginner+Ender" + count := 0 + lastletter := "" + + tokfile := open(tokfnm) | stop("unable to open \"", tokfnm, "\"") + opfile := open(opfnm) | stop("unable to open \"", opfnm, "\"") + toktab := open(toktbnm,"w") | stop("unable to create \"", toktbnm, "\"") + tok_dot_h := open(dothnm,"w") | stop("unable to create \"", dothnm, "\"") + write(" writing ", tokfnm, " and ", dothnm) + +# Output header for token table + write(toktab,"/*") + write(toktab," * NOTE: this file is generated automatically by ", prognm) + write(toktab," * from ", tokfnm, " and ", opfnm, ".") + write(toktab," */") + write(toktab) + write(toktab,"/*") + write(toktab," * Token table - contains an entry for each token type") + write(toktab," * with printable name of token, token type, and flags") + write(toktab," * for semicolon insertion.") + write(toktab," */") + write(toktab) + write(toktab,"struct toktab toktab[] = {") + write(toktab,"/* token\t\ttoken type\tflags */") + write(toktab) + write(toktab," /* primitives */") + +# output header for token include file + write(tok_dot_h,"/*") + write(tok_dot_h," * NOTE: these %token declarations are generated") + write(tok_dot_h," * automatically by ", prognm, " from ", tokfnm, " and ") + write(tok_dot_h," * ", opfnm, ".") + write(tok_dot_h," */") + write(tok_dot_h) + write(tok_dot_h, "/* primitive tokens */") + write(tok_dot_h) + + +# Skip the first few (non-informative) lines of "tokens.txt" + + garbage() + +# Read primitive tokens + + repeat { + write(toktab,makeline(token,tokval,bflag || eflag,count)) + wrt_tok_def(tokval) + count +:= 1 + line := read(tokfile) | stop("premature end-of-file") + line ? tokpat() | break + } + +# Skip some more garbage lines + + garbage() + +# Output some more comments + + write(toktab) + write(toktab," /* reserved words */") + write(tok_dot_h) + write(tok_dot_h, "/* reserved words */") + write(tok_dot_h) + +# Read in reserved words, output them, +# and build table of first letters. + + repeat { + write(toktab,makeline(token,tokval,bflag || eflag,count)) + wrt_tok_def(tokval, token) + letter := token[1] + if letter ~== lastletter then { + lastletter := letter + restable[letter] := count + } + count +:= 1 + line := read(tokfile) | stop("premature end-of-file") + if line ? tokpat() then next else break + } + +# output end of token table and reserveed word first-letter index. + + write(toktab,makeline("end-of-file","0","","")) + write(toktab," };") + write(toktab) + write(toktab,"/*") + write(toktab," * restab[c] points to the first reserved word in toktab which") + write(toktab," * begins with the letter c.") + write(toktab," */") + write(toktab) + write(toktab,"struct toktab *restab[] = {") + write(toktab,makeres("abcd", 16r61)) + write(toktab,makeres("efgh")) + write(toktab,makeres("ijkl")) + write(toktab,makeres("mnop")) + write(toktab,makeres("qrst")) + write(toktab,makeres("uvwx")) + write(toktab,makeres("yz")) + write(toktab," };") + +# Another comment + + write(toktab) + write(toktab,"/*") + write(toktab," * The operator table acts to extend the token table, it") + write(toktab," * indicates what implementations are expected from rtt,") + write(toktab," * and it has pointers for the implementation information.") + write(toktab," */") + write(toktab) + write(toktab, "struct optab optab[] = {") + write(tok_dot_h) + write(tok_dot_h, "/* operators */") + write(tok_dot_h) + +# read operator file + + tok_chars := &lcase ++ &ucase ++ '_' + + op_linenum := 0 + unary_set := set() + ops := table() + op_lst := [] + + while s := read(opfile) do { + op_linenum +:= 1 + s ? { + tab(many(white_sp)) + if pos(0) | = "#" then + next + op := tab(upto(white_sp)) | err(opfnm, op_linenum, + "unexpected end of line") + tab(many(white_sp)) + if ="(:=" then { + tab(many(white_sp)) + if not ="AUG)" then + err(opfnm, op_linenum, "invalid augmented indication") + tab(many(white_sp)) + aug := 1 + } + else + aug := &null + tok := tab(many(tok_chars)) | err(opfnm, op_linenum, "invalid token") + tab(many(white_sp)) + unary := tab(any('_us')) | err(opfnm,op_linenum,"invalid unary flag") + tab(many(white_sp)) + binary := tab(any('_bs')) | err(opfnm,op_linenum,"invalid binary flag") + if unary == "_" & binary == "_" then + err(opfnm, op_linenum, "either unary or binary flag must be set") + if unary ~== "_" then { + if *op ~= 1 then + err(opfnm, op_linenum, + "unary operators must be single characters: " || op); + insert(unary_set, op) + } + if \aug & binary == "_" then + err(opfnm, op_linenum, + "binary flag must be set for augmented assignment") + + ops[op] := op_sym(op, aug, tok, unary, binary) + } + } + + ops := sort(ops, 3) + while get(ops) & sym := get(ops) do + op_out(sym.op, sym.aug, sym.tokval, sym.unary, sym.binary) + +# Skip more garbage + + garbage() + +repeat { + wrt_op(token, tokval, bflag || eflag, 0, 1) + line := read(tokfile) | stop("premature end-of-file") + line ? tokpat() | break + } + +# Skip more garbage + + garbage() + +repeat { + wrt_op(token, tokval, bflag || eflag, 0, &null) + line := read(tokfile) | stop("premature end-of-file") + line ? tokpat() | break + } + write(toktab, + " {{NULL, 0, 0}, 0, NULL, NULL}") + write(toktab, " };") + + write(toktab) + if /asgn_loc then + stop(opfnm, " does not contain a definition for ':='") + if /semicol_loc then + stop(tokfnm, " does not contain a definition for ';'") + if /plus_loc then + stop(tokfnm, " does not contain a definition for '+'") + if /minus_loc then + stop(tokfnm, " does not contain a definition for '-'") + write(toktab, "int asgn_loc = ", asgn_loc, ";") + write(toktab, "int semicol_loc = ", semicol_loc, ";") + write(toktab, "int plus_loc = ", plus_loc, ";") + write(toktab, "int minus_loc = ", minus_loc, ";") + + op_trie := build_trie(op_lst) + + write(toktab); + wrt(toktab, 0, "/*") + wrt(toktab, 0, " * getopr - find the longest legal operator and return the") + wrt(toktab, 0, " * index to its entry in the operator table.") + wrt(toktab, 0, " */\n") + wrt(toktab, 0, "int getopr(ac, cc)") + wrt(toktab, 0, "int ac;") + wrt(toktab, 0, "int *cc;") + wrt(toktab, 1, "{") + wrt(toktab, 1, "register char c;\n") + wrt(toktab, 1, "*cc = ' ';") + bld_slct(op_trie, "", "ac", toktab, 1) + wrt(toktab, 1, "tfatal(\"invalid character\", (char *)NULL);") + wrt(toktab, 1, "return -1;") + wrt(toktab, 1, "}") +end + +procedure makeline(token,tokval,flag,count) # build an output line for token table. + local line + line := left(" \"" || token || "\",",22) || left(tokval || ",",15) + flag := flagtable[flag] || "," + if count ~=== "" then flag := left(flag,19) + line ||:= flag + if count ~=== "" then line ||:= "/* " || right(count,3) || " */" + return line +end + +# makeres - build an output line for reserved word index. +# +procedure makeres(lets, strt_repr) + local let, letters, line + static repr + + repr := \strt_repr + + line := " " + letters := lets + every let := !lets do + if let ~== "." & \restable[let] then { + line ||:= "&toktab[" || right(restable[let],2) || "], " + } + else line ||:= "NULL, " + line := left(line,55) || "/* " + if integer(repr) then + line ||:= hex(repr) || "-" || hex((repr +:= *lets) - 1) || " " + return line || letters || " */" +end + +procedure garbage() + local line + while line := read(tokfile) | stop("premature end-of-file") do + if line ? tokpat() then return +end + +procedure hex(n) + local s + static hexdig + + initial hexdig := "0123456789ABCDEF" + + s := "" + while n > 0 do { + s := hexdig[n % 16 + 1] || s + n := n / 16 + } + return s +end + +procedure op_out(op, aug, tokval, unary, binary) + local flag, arity + + if unary_str(op) then + flag := "b" + else + flag := "" + if unary == "u" then + arity := "Unary" + if binary == "b" then + if /arity then + arity := "Binary" + else + arity ||:= " | Binary" + /arity := "0" + wrt_op(op, tokval, flag, arity, 1) + if \aug then + wrt_op(op || ":=", "AUG" || tokval, "", "0", 1) +end + +procedure wrt_op(op, tokval, flag, arity, define) + static cnt + + initial cnt := 0; + + flag := flagtable[flag] + writes(toktab, " {{\"", left(esc(op) || "\",", 9)) + writes(toktab, left(tokval || ",", 12)) + writes(toktab, left(flag || "},", 11)) + writes(toktab, left(arity|| ",", 16)) + write(toktab, "NULL, NULL}, /* ", cnt, " */") + if \define then + wrt_tok_def(tokval, op) + if op == ":=" then + asgn_loc := cnt + else if op == ";" then + semicol_loc := cnt + else if op == "+" then + plus_loc := cnt + else if op == "-" then + minus_loc := cnt + put(op_lst, association(op, cnt)) + cnt +:= 1 +end + +procedure wrt_tok_def(tokval, tok) + if \tok then + write(tok_dot_h, "%token\t", left(tokval, 12), "/* ", left(tok, 9), + " */") + else + write(tok_dot_h, "%token\t", tokval); +end + +procedure unary_str(op) + if op == "" then + return + if member(unary_set, op[1]) then + return unary_str(op[2:0]) +end + +procedure err(file, line, msg) + stop(&errout, "file: ", file, ", line: ", line, " - ", msg) +end + +procedure build_trie(ops) + local by_1st_c, dflt, asc, c, c_ops + + by_1st_c := table() + every asc := !ops do { + # + # See if there are more characters in this operator. + # + if c := asc.op[1] then { + /by_1st_c[c] := [] + put(by_1st_c[c], association(asc.op[2:0], asc.n)) + } + else + dflt := asc.n + } + by_1st_c := sort(by_1st_c) + every c_ops := !by_1st_c do + c_ops[2] := build_trie(c_ops[2]) + return trie(by_1st_c, dflt) +end + + +# bld_slct - output selection code which will recongize operators +# represented by the given trie. Code has already been generated +# to recognize the string in prefix. +procedure bld_slct(op_trie, prefix, char_src, f, indent) + local fall_through, by_1st_c, dflt, char, trie_1, a, ft + + by_1st_c := op_trie.by_1st_c + dflt := op_trie.dflt + + case *by_1st_c of { + 0: + # + # There are no more characters to check. When execution gets + # here in the generated code we have found a longest possible + # operator: the one contained in prefix. + # + wrt(f, indent, "return " , dflt, "; /* ", prefix, " */") + 1: { + # + # If there is only one valid character to check for, generate an + # if statement rather than a switch statement. If the character + # is not next in the input, either we are already at the end of + # a valid operator (in which case, the generated code must + # must save the one-character look ahead) or the generated + # code will fall through to an error message at the end of the + # function. + # + char := by_1st_c[1][1] + trie_1 := by_1st_c[1][2] + wrt(f, indent, "if ((c = ", char_src, ") == '", esc(char), "') {") + fall_through := bld_slct(trie_1, prefix || char, "NextChar", f, + indent + 1) + wrt(f, indent + 1, "}") + if \dflt then { + wrt(f, indent, "else {") + wrt(f, indent + 1, "*cc = c;") + wrt(f, indent + 1, "return " , dflt, "; /* ", prefix, " */") + wrt(f, indent + 1, "}") + } + else + fall_through := 1 + } + default: { + # + # There are several possible next characters. Produce a switch + # statement to check for them. + # + wrt(f, indent, "switch (c = ", char_src, ") {") + every a := !by_1st_c do { + char := a[1] + trie_1 := a[2] + wrt(f, indent + 1, "case '", esc(char), "':") + ft := bld_slct(trie_1, prefix || char, "NextChar", f, indent + 2) + if \ft then { + wrt(f, indent + 2, "break;") + fall_through := 1 + } + } + if \dflt then { + wrt(f, indent + 1, "default:") + wrt(f, indent + 2, "*cc = c;") + wrt(f, indent + 2, "return " , dflt, "; /* ", prefix, " */") + } + else + fall_through := 1 + wrt(f, indent + 1, "}") + } + } + + return fall_through +end + +procedure wrt(f, indent, slst[]) + local s1, i, exp_indent + + exp_indent := indent * 3; + s1 := repl(" ", exp_indent) + while s1 ||:= get(slst) + if (*s1 > 80) then { + # + # line too long, find first space before 80th column, and + # break there. note, this will not work in general. it may + # break a line within a string. + # + every i := 80 to 1 by -1 do + if s1[i] == " " then + if i <= exp_indent then { + # + # we have indented too far + # + wrt(f, indent - 1, s1[exp_indent+1:0]) + return + } + else { + write(f, s1[1:i]) + wrt(f, indent, s1[i+1:0]) + return + } + } + write(f, s1) +end + +procedure esc(c) + if c == "\\" then + return "\\\\" + else + return c +end diff --git a/src/common/munix.c b/src/common/munix.c new file mode 100644 index 0000000..132f397 --- /dev/null +++ b/src/common/munix.c @@ -0,0 +1,258 @@ +/* + * munix.c -- special common code from Unix + * + * (Originally used only under Unix, but now on all platforms.) + */ + +#include "../h/gsupport.h" + +#include +#include +#include +#include +#include +#include + +/* + * relfile(prog, mod) -- find related file. + * + * Given that prog is the argv[0] by which this program was executed, + * and assuming that it was set by the shell or other equally correct + * invoker, relfile finds the location of a related file and returns + * it in an allocated string. It takes the location of prog, appends + * mod, and canonizes the result; thus if argv[0] is icont or its path, + * relfile(argv[0],"/../iconx") finds the location of iconx. + */ +char *relfile(char *prog, char *mod) { + static char baseloc[MaxPath]; + char buf[MaxPath]; + + if (baseloc[0] == 0) { /* if argv[0] not already found */ + + #if CYGWIN + char posix_prog[_POSIX_PATH_MAX + 1]; + cygwin_conv_to_posix_path(prog, posix_prog); + prog = posix_prog; + #endif /* CYGWIN */ + + if (findexe(prog, baseloc, sizeof(baseloc)) == NULL) { + fprintf(stderr, "cannot find location of %s\n", prog); + exit(EXIT_FAILURE); + } + if (followsym(baseloc, buf, sizeof(buf)) != NULL) + strcpy(baseloc, buf); + } + + strcpy(buf, baseloc); /* start with base location */ + strcat(buf, mod); /* append adjustment */ + canonize(buf); /* canonize result */ + if (mod[strlen(mod)-1] == '/') /* if trailing slash wanted */ + strcat(buf, "/"); /* append to result */ + return salloc(buf); /* return allocated string */ + } + +/* + * findexe(prog, buf, len) -- find absolute executable path, given argv[0] + * + * Finds the absolute path to prog, assuming that prog is the value passed + * by the shell in argv[0]. The result is placed in buf, which is returned. + * NULL is returned in case of error. + */ + +char *findexe(char *name, char *buf, size_t len) { + int n; + char *s; + + if (name == NULL) + return NULL; + + /* if name does not contain a slash, search $PATH for file */ + if (strchr(name, '/') != NULL) + strcpy(buf, name); + else if (findonpath(name, buf, len) == NULL) + return NULL; + + /* if path is not absolute, prepend working directory */ + if (buf[0] != '/') { + n = strlen(buf) + 1; + memmove(buf + len - n, buf, n); + if (getcwd(buf, len - n) == NULL) + return NULL; + s = buf + strlen(buf); + *s = '/'; + memcpy(s + 1, buf + len - n, n); + } + canonize(buf); + return buf; + } + +/* + * findonpath(name, buf, len) -- find name on $PATH + * + * Searches $PATH (using POSIX 1003.2 rules) for executable name, + * writing the resulting path in buf if found. + */ +char *findonpath(char *name, char *buf, size_t len) { + int nlen, plen; + char *path, *next, *sep, *end; + struct stat status; + + nlen = strlen(name); + path = getenv("PATH"); + + if (path == NULL || *path == '\0') + path = "."; + #if CYGWIN + else { + char *posix_path; + posix_path = alloca(cygwin_win32_to_posix_path_list_buf_size(path)); + cygwin_win32_to_posix_path_list(path, posix_path); + path = posix_path; + } + #endif /* CYGWIN */ + + end = path + strlen(path); + for (next = path; next <= end; next = sep + 1) { + sep = strchr(next, ':'); + if (sep == NULL) + sep = end; + plen = sep - next; + if (plen == 0) { + next = "."; + plen = 1; + } + if (plen + 1 + nlen + 1 > len) + return NULL; + memcpy(buf, next, plen); + buf[plen] = '/'; + strcpy(buf + plen + 1, name); + if (access(buf, X_OK) == 0) { + if (stat(buf, &status) == 0 && S_ISREG(status.st_mode)) + return buf; + } + } + return NULL; + } + +/* + * followsym(name, buf, len) -- follow symlink to final destination. + * + * If name specifies a file that is a symlink, resolves the symlink to + * its ultimate destination, and returns buf. Otherwise, returns NULL. + * + * Note that symlinks in the path to name do not make it a symlink. + * + * buf should be long enough to hold name. + */ + +#define MAX_FOLLOWED_LINKS 24 + +char *followsym(char *name, char *buf, size_t len) { + int i, n; + char *s, tbuf[MaxPath]; + + strcpy(buf, name); + + for (i = 0; i < MAX_FOLLOWED_LINKS; i++) { + if ((n = readlink(buf, tbuf, sizeof(tbuf) - 1)) <= 0) + break; + tbuf[n] = 0; + + if (tbuf[0] == '/') { + if (n < len) + strcpy(buf, tbuf); + else + return NULL; + } + else { + s = strrchr(buf, '/'); + if (s != NULL) + s++; + else + s = buf; + if ((s - buf) + n < len) + strcpy(s, tbuf); + else + return NULL; + } + canonize(buf); + } + + if (i > 0 && i < MAX_FOLLOWED_LINKS) + return buf; + else + return NULL; + } + +/* + * canonize(path) -- put file path in canonical form. + * + * Rewrites path in place, and returns it, after excising fragments of + * "." or "dir/..". All leading slashes are preserved but other extra + * slashes are deleted. The path never grows longer except for the + * special case of an empty path, which is rewritten to be ".". + * + * No check is made that any component of the path actually exists or + * that inner components are truly directories. From this it follows + * that if "foo" is any file path, canonizing "foo/.." produces the path + * of the directory containing "foo". + */ + +char *canonize(char *path) { + int len; + char *root, *end, *in, *out, *prev; + + /* initialize */ + root = path; /* set barrier for trimming by ".." */ + end = path + strlen(path); /* set end of input marker */ + while (*root == '/') /* preserve all leading slashes */ + root++; + in = root; /* input pointer */ + out = root; /* output pointer */ + + /* scan string one component at a time */ + while (in < end) { + + /* count component length */ + for (len = 0; in + len < end && in[len] != '/'; len++) + ; + + /* check for ".", "..", or other */ + if (len == 1 && *in == '.') /* just ignore "." */ + in++; + else if (len == 2 && in[0] == '.' && in[1] == '.') { + in += 2; /* skip over ".." */ + /* find start of previous component */ + prev = out; + if (prev > root) + prev--; /* skip trailing slash */ + while (prev > root && prev[-1] != '/') + prev--; /* find next slash or start of path */ + if (prev < out - 1 + && (out - prev != 3 || strncmp(prev, "../", 3) != 0)) { + out = prev; /* trim trailing component */ + } + else { + memcpy(out, "../", 3); /* cannot trim, so must keep ".." */ + out += 3; + } + } + else { + memmove(out, in, len); /* copy component verbatim */ + out += len; + in += len; + *out++ = '/'; /* add output separator */ + } + + while (in < end && *in == '/') /* consume input separators */ + in++; + } + + /* final fixup */ + if (out > root) + out--; /* trim trailing slash */ + if (out == path) + *out++ = '.'; /* change null path to "." */ + *out++ = '\0'; + return path; /* return result */ + } diff --git a/src/common/op.txt b/src/common/op.txt new file mode 100644 index 0000000..fa80fc5 --- /dev/null +++ b/src/common/op.txt @@ -0,0 +1,61 @@ +# This file contains tokens for symbols used in standard unary/binary syntax +# +# operator token unary/binary/special (see notes at bottom) + + := ASSIGN _ b + :=: SWAP _ b + <- REVASSIGN _ b + <-> REVSWAP _ b + & (:= AUG) AND s b # unary form is for keywords + @ (:= AUG) AT s s # control structures for activation + ^ (:= AUG) CARET u b + || (:= AUG) CONCAT _ b + -- (:= AUG) DIFF _ b + === (:= AUG) EQUIV _ b + ** (:= AUG) INTER _ b + ||| (:= AUG) LCONCAT _ b + - (:= AUG) MINUS u b + % (:= AUG) MOD _ b + ~=== (:= AUG) NEQUIV _ b + = (:= AUG) NMEQ u b + >= (:= AUG) NMGE _ b + > (:= AUG) NMGT _ b + <= (:= AUG) NMLE _ b + < (:= AUG) NMLT _ b + ~= (:= AUG) NMNE _ b + + (:= AUG) PLUS u b + ? (:= AUG) QMARK u s # binary form is a control structure + == (:= AUG) SEQ _ b + >>= (:= AUG) SGE _ b + >> (:= AUG) SGT _ b + <<= (:= AUG) SLE _ b + << (:= AUG) SLT _ b + ~== (:= AUG) SNE _ b + / (:= AUG) SLASH u b + * (:= AUG) STAR u b + ++ (:= AUG) UNION _ b + \ BACKSLASH u s # binary form is a control structure + | BAR s s # unary & binary forms are control strutures + ! BANG u s # binary form is a control structure + . DOT u s # binary form is for field references + ~ TILDE u _ + + +# notes, +# +# (:= AUG) indicates that the binary operator has an augmented +# assignment form. For example, the entry +# + (:= AUG) PLUS ub +# acts like two entries: +# + PLUS ub +# +:= AUGPLUS b +# except that the compiler automatically combines the +# implementations for + and := to implement +:=. +# +# 1st flag: _ - no unary form +# u - unary operator implemented by .rtt file +# s - unary form but special implementation within the compiler +# +# 2st flag: _ - no binary form +# b - binary operator implemented by .rtt file +# s - binary form but special implementation within the compiler diff --git a/src/common/patchstr.c b/src/common/patchstr.c new file mode 100644 index 0000000..7edc24c --- /dev/null +++ b/src/common/patchstr.c @@ -0,0 +1,189 @@ +/* + * patchstr.c -- install a string at preconfigured points in an executable + * + * Usage: patchstr filename newstring -- to patch a file + * patchstr filename -- to report existing values + * + * Patchstr installs or changes strings in an executable file. It replaces + * null-terminated strings of up to 500 characters that are immediately + * preceded by the eighteen (unterminated) characters "%PatchStringHere->". + * + * If the new string is shorter than the old string, it is null-padded. + * If the old string is shorter, it must have suffient null padding to + * accept the new string. + * + * If no "newstring" is specified, existing values are printed. + * + * 4-Aug-91, 14-Feb-92 gmt + */ + +#include "../h/rt.h" + +#undef strlen + +void report (char *filename); +void patchstr (char *filename, char *newstring); +int findpattern (FILE *f); +int oldval (FILE *f, char *buf); + +/* guard pattern; first character must not reappear later */ +#define PATTERN "%PatchStringHere->" + +/* maximum string length */ +#define MAXLEN 500 + +int exitcode = 0; /* exit code; nonzero if any problems */ +int nfound = 0; /* number of strings found */ +int nchanged = 0; /* number of strings changed */ + +/* + * main program + */ +int main (argc, argv) +int argc; +char *argv[]; + { + char *fname, *newstr; + + if (argc < 2 || argc > 3) { + fprintf(stderr, "usage: %s filename [newstring]\n", argv[0]); + exit(1); + } + fname = argv[1]; + newstr = argv[2]; + if (newstr) + patchstr(fname, newstr); + else + report(fname); + exit(exitcode); + /*NOTREACHED*/ + } + +/* + * report (filename) -- report existing string values in a file + */ +void report (fname) +char *fname; + { + FILE *f; + long posn; + int n; + char buf[MAXLEN+2]; + + if (!(f = fopen(fname, "rb"))) { /* open read-only */ + perror(fname); + exit(1); + } + while (findpattern(f)) { /* find occurrence of magic string */ + nfound++; + posn = ftell(f); /* remember current location */ + n = oldval(f, buf); /* check available space */ + fseek(f, posn, 0); /* reposition to beginning of string */ + if (n > MAXLEN) { + strcpy (buf+40, "... [unterminated]"); + exitcode = 1; + } + printf("at byte %ld:\t%s\n", posn, buf); /* print value */ + } + if (nfound == 0) { + fprintf(stderr, "flag pattern not found\n"); + exitcode = 1; + } + } + +/* + * patchstr (filename, newstring) -- patch a file + */ +void patchstr (fname, newstr) +char *fname, *newstr; + { + FILE *f; + long posn; + int n; + char buf[MAXLEN+2]; + + if (!(f = fopen(fname, "r+b"))) { /* open for read-and-update */ + perror(fname); + exit(1); + } + while (findpattern(f)) { /* find occurrence of magic string */ + nfound++; + posn = ftell(f); /* remember current location */ + n = oldval(f, buf); /* check available space */ + fseek(f, posn, 0); /* reposition to beginning of string */ + if (n > MAXLEN) { + fprintf(stderr, "at byte %ld: unterminated string\n", posn); + exitcode = 1; + } + else if (n < (int)strlen(newstr)) { + fprintf (stderr, "at byte %ld: buffer only holds %d characters\n", + posn, n); + exitcode = 1; + } + else { + fputs(newstr, f); /* rewrite string with new value */ + n -= strlen(newstr); + while (n-- > 0) + putc('\0', f); /* pad out with NUL characters */ + nchanged++; + fseek(f, 0L, 1); /* re-enable reading */ + } + } + if (nfound == 0) { + fprintf(stderr, "flag pattern not found\n"); + exitcode = 1; + } + else + fprintf(stderr, "replaced %d occurrence%s\n", nchanged, + nchanged == 1 ? "" : "s"); + } + +/* + * findpattern(f) - read until the magic pattern has been matched + * + * Return 1 if successful, 0 if not. + */ +int findpattern(f) +FILE *f; + { + int c; + char *p; + + p = PATTERN; /* p points to next char we're looking for */ + for (;;) { + c = getc(f); /* get next char from file */ + if (c == EOF) + return 0; /* if EOF, give up */ + if (c != *p) { + p = PATTERN; /* if mismatch, start over */ + if (c == *p) /* (but see if matched pattern start) */ + p++; + continue; + } + if (*++p == '\0') /* if entire pattern matched */ + return 1; + } + } + +/* + * oldval(f, buf) - read old string into buf and return usable length + * + * The "usable" (replaceable) length for rewriting takes null padding into + * account up to MAXLEN. A returned value greater than that indicates an + * unterminated string. The file will need to be repositioned after calling + * this function. + */ +int oldval(f, buf) +FILE *f; +char buf[MAXLEN+2]; + { + int n; + char *e, *p; + + n = fread(buf, 1, MAXLEN+1, f); /* read up to MAXLEN + null char */ + e = buf + n; /* note end of read area */ + n = strlen(buf); /* count string length proper */ + for (p = buf + n + 1; p < e && *p == '\0'; p++) + n++; /* count nulls beyond end */ + return n; /* return usable length */ + } diff --git a/src/common/pscript.icn b/src/common/pscript.icn new file mode 100644 index 0000000..d9b2ee7 --- /dev/null +++ b/src/common/pscript.icn @@ -0,0 +1,44 @@ +# Program to sanitize Yacc output and minor changes to it to suit the Icon +# translator. + +# procedure to skip optional white space. +procedure sws() + return tab( many( ' \t' ) ) | "" +end + +$ifdef _CYGWIN + $define YY_STATE "yystate" +$else # _CYGWIN + $define YY_STATE "yy_state" +$endif # _CYGWIN + +procedure main() + local line, prefix + + while line := read() do { + if line == "#" then next # omit lone #s -- illegal now + else line ? { + if write(="#endif") then next # omit illegal stuff + else if (prefix := tab(find("yyerror"))) & ="yyerror" & sws() & ="(" & + sws() & ="\"" then { + # + # We are beyond the 'yyerror( "'. Write the part of the + # line before the call, then decide what to do about + # the error message that follows. + # + writes(prefix) + if ="syntax error\"" then + writes("yyerror(yychar, yylval, ", YY_STATE) + else if ="yacc stack overflow\"" then + writes("tsyserr(\"parse stack overflow\"") + else + writes("tsyserr(\"parser: ") + write(tab(0)) + } + else if ="extern char *malloc(), *realloc();" then { + # let proto.h handle this declaration. + } + else write(tab(0)) + } + } +end diff --git a/src/common/rtdb.c b/src/common/rtdb.c new file mode 100644 index 0000000..5467244 --- /dev/null +++ b/src/common/rtdb.c @@ -0,0 +1,1692 @@ +/* + * Routines to read a data base of run-time information. + */ +#include "../h/gsupport.h" +#include "../h/version.h" +#include "icontype.h" + +/* + * GetInt - the next thing in the data base is an integer. Get it. + */ +#define GetInt(n, c)\ + n = 0;\ + while (isdigit(c)) {\ + n = n * 10 + (c - '0');\ + c = getc(db);\ + } + +/* + * SkipWhSp - skip white space characters in the data base. + */ +#define SkipWhSp(c)\ + while (isspace(c)) {\ + if (c == '\n')\ + ++dbline;\ + c = getc(db);\ + } + +/* + * prototypes for static functions. + */ +static int cmp_1_pre (int p1, int p2); +static struct il_code *db_abstr (void); +static void db_case (struct il_code *il, int num_cases); +static void db_err3 (int fatal,char *s1,char *s2,char *s3); +static int db_icntyp (void); +static struct il_c *db_ilc (void); +static struct il_c *db_ilcret (int il_c_type); +static struct il_code *db_inlin (void); +static struct il_code *db_ilvar (void); +static int db_rtflg (void); +static int db_tndtyp (void); +static struct il_c *new_ilc (int il_c_type); +static void quoted (int delim); + +extern char *progname; /* name of program using this module */ + +static char *dbname; /* data base name */ +static FILE *db; /* data base file */ +static int dbline; /* line number current position in data base */ +static struct str_buf db_sbuf; /* string buffer */ +static int *type_map; /* map data base type codes to internal ones */ +static int *compnt_map; /* map data base component codes to internal */ + +/* + * opendb - open data base and do other house keeping. + */ +int db_open(s, lrgintflg) +char *s; +char **lrgintflg; + { + char *msg_buf; + char *id; + int i, n; + register int c; + static int first_time = 1; + + if (first_time) { + first_time = 0; + init_sbuf(&db_sbuf); + } + dbname = s; + dbline = 0; + *lrgintflg = NULL; + db = fopen(dbname, "rb"); + if (db == NULL) + return 0; + ++dbline; + + /* + * Make sure the version number in the data base is what is expected. + */ + s = db_string(); + if (strcmp(s, DVersion) != 0) { + msg_buf = alloc(35 + strlen(s) + strlen(progname) + strlen(DVersion)); + sprintf(msg_buf, "found version %s, %s requires version %s", + s, progname, DVersion); + db_err1(1, msg_buf); + } + + *lrgintflg = db_string(); /* large integer flag */ + + /* + * Create tables for mapping type codes and type component codes in + * the data base to those compiled into this program. The codes may + * be different if types have been added to the program since the + * data base was created. + */ + type_map = alloc(num_typs * sizeof(int)); + db_chstr("", "types"); /* verify section header */ + c = getc(db); + SkipWhSp(c) + while (c == 'T') { + c = getc(db); + if (!isdigit(c)) + db_err1(1, "expected type code"); + GetInt(n, c) + if (n >= num_typs) + db_err1(1, "data base inconsistant with program, rebuild data base"); + SkipWhSp(c) + if (c != ':') + db_err1(1, "expected ':'"); + id = db_string(); + for (i = 0; strcmp(id, icontypes[i].id) != 0; ++i) + if (i >= num_typs) + db_err2(1, "unknown type:", id); + type_map[n] = i; + c = getc(db); + SkipWhSp(c) + } + db_chstr("", "endsect"); + + compnt_map = alloc(num_cmpnts * sizeof(int)); + db_chstr("", "components"); /* verify section header */ + c = getc(db); + SkipWhSp(c) + while (c == 'C') { + c = getc(db); + if (!isdigit(c)) + db_err1(1, "expected type component code"); + GetInt(n, c) + if (n >= num_cmpnts) + db_err1(1, "data base inconsistant with program, rebuild data base"); + SkipWhSp(c) + if (c != ':') + db_err1(1, "expected ':'"); + id = db_string(); + for (i = 0; strcmp(id, typecompnt[i].id) != 0; ++i) + if (i >= num_cmpnts) + db_err2(1, "unknown type component:", id); + compnt_map[n] = i; + c = getc(db); + SkipWhSp(c) + } + db_chstr("", "endsect"); + + return 1; + } + +/* + * db_close - close data base. + */ +void db_close() + { + if (fclose(db) != 0) + db_err2(0, "cannot close", dbname); + } + +/* + * db_string - get a white-space delimited string from the data base. + */ +char *db_string() + { + register int c; + + /* + * Look for the start of the string; '$' starts a special indicator. + * Copy characters into string buffer until white space is found. + */ + c = getc(db); + SkipWhSp(c); + if (c == EOF) + db_err1(1, "unexpected EOF"); + if (c == '$') + return NULL; + while (!isspace(c) && c != EOF) { + AppChar(db_sbuf, c); + c = getc(db); + } + if (c == '\n') + ++dbline; + return str_install(&db_sbuf); /* put string in string table */ + } + +/* + * db_impl - read basic header information for an operation into a structure + * and return it. + */ +struct implement *db_impl(oper_typ) +int oper_typ; + { + register struct implement *ip; + register int c; + int i; + char *name; + long n; + + /* + * Get operation name. + */ + if ((name = db_string()) == NULL) + return NULL; + + /* + * Create an internal structure to hold the data base entry. + */ + ip = NewStruct(implement); + ip->blink = NULL; + ip->iconc_flgs = 0; /* reserved for internal use by compiler */ + ip->oper_typ = oper_typ; + ip->name = name; + ip->op = NULL; + + /* + * Get the function name prefix assigned to this operation. + */ + c = getc(db); + SkipWhSp(c) + if (isalpha(c) || isdigit(c)) + ip->prefix[0] = c; + else + db_err2(1, "invalid prefix for", ip->name); + c = getc(db); + if (isalpha(c) || isdigit(c)) + ip->prefix[1] = c; + else + db_err2(1, "invalid prefix for", ip->name); + + /* + * Get the number of parameters. + */ + c = getc(db); + SkipWhSp(c) + if (!isdigit(c)) + db_err2(1, "number of parameters missing for", ip->name); + GetInt(n, c) + ip->nargs = n; + + /* + * Get the flags that indicate whether each parameter requires a dereferenced + * and/or undereferenced value, and whether the last parameter represents + * the end of a varargs list. Store the flags in an array. + */ + if (n == 0) + ip->arg_flgs = NULL; + else + ip->arg_flgs = alloc(n * sizeof(int)); + if (c != '(') + db_err2(1, "parameter flags missing for", ip->name); + c = getc(db); + for (i = 0; i < n; ++i) { + if (c == ',' || c == ')') + db_err2(1, "parameter flag missing for", ip->name); + ip->arg_flgs[i] = 0; + while (c != ',' && c != ')') { + switch (c) { + case 'u': + ip->arg_flgs[i] |= RtParm; + break; + case 'd': + ip->arg_flgs[i] |= DrfPrm; + break; + case 'v': + ip->arg_flgs[i] |= VarPrm; + break; + default: + db_err2(1, "invalid parameter flag for", ip->name); + } + c = getc(db); + } + if (c == ',') + c = getc(db); + } + if (c != ')') + db_err2(1, "invalid parameter flag list for", ip->name); + + /* + * Get the result sequence indicator for the operation. + */ + c = getc(db); + SkipWhSp(c) + if (c != '{') + db_err2(1, "result sequence missing for", ip->name); + c = getc(db); + ip->resume = 0; + if (c == '}') { + ip->min_result = NoRsltSeq; + ip->max_result = NoRsltSeq; + } + else { + if (!isdigit(c)) + db_err2(1, "invalid result sequence for", ip->name); + GetInt(n, c) + ip->min_result = n; + if (c != ',') + db_err2(1, "invalid result sequence for", ip->name); + c = getc(db); + if (c == '*') { + ip->max_result = UnbndSeq; + c = getc(db); + } + else if (isdigit(c)) { + GetInt(n, c) + ip->max_result = n; + } + else + db_err2(1, "invalid result sequence for", ip->name); + if (c == '+') { + ip->resume = 1; + c = getc(db); + } + if (c != '}') + db_err2(1, "invalid result sequence for", ip->name); + } + + /* + * Get the flag indicating whether the operation contains returns, fails, + * or suspends. + */ + ip->ret_flag = db_rtflg(); + + /* + * Get the t/f flag that indicates whether the operation explicitly + * uses the 'result' location. + */ + c = getc(db); + SkipWhSp(c) + switch (c) { + case 't': + ip->use_rslt = 1; + break; + case 'f': + ip->use_rslt = 0; + break; + default: + db_err2(1, "invalid 'result' use indicator for", ip->name); + } + return ip; + } + +/* + * db_code - read the RTL code for the body of an operation. + */ +void db_code(ip) +struct implement *ip; + { + register int c; + char *s; + word n; + int var_type; + int i; + + /* + * read the descriptive string. + */ + c = getc(db); + SkipWhSp(c) + if (c != '"') + db_err1(1, "operation description expected"); + for (c = getc(db); c != '"' && c != '\n' && c != EOF; c = getc(db)) { + if (c == '\\') { + AppChar(db_sbuf, c); + c = getc(db); + } + AppChar(db_sbuf, c); + } + if (c != '"') + db_err1(1, "expected '\"'"); + ip->comment = str_install(&db_sbuf); + + /* + * Get the number of tended variables in the declare clause. + */ + c = getc(db); + SkipWhSp(c) + GetInt(n, c) + ip->ntnds = n; + + /* + * Read information about the tended variables into an array. + */ + if (n == 0) + ip->tnds = NULL; + else + ip->tnds = alloc(n * sizeof(struct tend_var)); + for (i = 0; i < n; ++i) { + var_type = db_tndtyp(); /* type of tended declaration */ + ip->tnds[i].var_type = var_type; + ip->tnds[i].blk_name = NULL; + if (var_type == TndBlk) { + /* + * Tended block pointer declarations include a block type or '*' to + * indicate 'union block *'. + */ + s = db_string(); + if (s == NULL) + db_err1(1, "block name expected"); + if (*s != '*') + ip->tnds[i].blk_name = s; + } + ip->tnds[i].init = db_ilc(); /* C code for declaration initializer */ + } + + /* + * Get the number of non-tended variables in the declare clause. + */ + c = getc(db); + SkipWhSp(c) + GetInt(n, c) + ip->nvars = n; + + /* + * Get each non-tended declaration and store it in an array. + */ + if (n == 0) + ip->vars = NULL; + else + ip->vars = alloc(n * sizeof(struct ord_var)); + for (i = 0; i < n; ++i) { + s = db_string(); /* variable name */ + if (s == NULL) + db_err1(1, "variable name expected"); + ip->vars[i].name = s; + ip->vars[i].dcl = db_ilc(); /* full declaration including name */ + } + + /* + * Get the executable RTL code. + */ + ip->in_line = db_inlin(); + + /* + * We should be at the end of the operation. + */ + c = getc(db); + SkipWhSp(c) + if (c != '$') + db_err1(1, "expected $end"); + } + +/* + * db_inlin - read in the in-line code (executable RTL code) for an operation. + */ +static struct il_code *db_inlin() + { + struct il_code *il = NULL; + register int c; + int i; + int indx; + int fall_thru; + int n, n1; + + /* + * The following nested switch statements act as a trie for recognizing + * the prefix form of RTL code in the data base. + */ + c = getc(db); + SkipWhSp(c) + switch (c) { + case 'a': + switch (getc(db)) { + case 'b': { + db_chstr("ab", "str"); + il = new_il(IL_Abstr, 2); /* abstract type computation */ + il->u[0].fld = db_abstr(); /* side effects */ + il->u[1].fld = db_abstr(); /* return type */ + break; + } + case 'c': { + db_chstr("ac", "ase"); + il = new_il(IL_Acase, 5); /* arith_case */ + il->u[0].fld = db_ilvar(); /* first variable */ + il->u[1].fld = db_ilvar(); /* second variable */ + il->u[2].fld = db_inlin(); /* C_integer action */ + il->u[3].fld = db_inlin(); /* integer action */ + il->u[4].fld = db_inlin(); /* C_double action */ + break; + } + default: + db_err1(1, "expected abstr or acase"); + } + break; + + case 'b': + db_chstr("b", "lock"); + c = getc(db); + SkipWhSp(c) + if (c == 't') + fall_thru = 1; + else + fall_thru = 0; + c = getc(db); + SkipWhSp(c) + GetInt(n, c) + il = new_il(IL_Block, 3 + n); /* block of in-line C code */ + il->u[0].n = fall_thru; + il->u[1].n = n; /* number of local tended */ + for (i = 2; i - 2 < n; ++i) + il->u[i].n = db_tndtyp(); /* tended declaration */ + il->u[i].c_cd = db_ilc(); /* C code */ + break; + + case 'c': + switch (getc(db)) { + case 'a': { + char prfx3; + int ret_val = 0; + int ret_flag; + int rslt = 0; + int num_sbuf; + int num_cbuf; + + db_chstr("ca", "ll"); + /* + * Call to body function. Get the letter used as the 3rd + * character of the function prefix. + */ + c = getc(db); + SkipWhSp(c) + prfx3 = c; + + /* + * Determine what the body function returns directly. + */ + c = getc(db); + SkipWhSp(c) + switch (c) { + case 'i': + ret_val = RetInt; /* returns C integer */ + break; + case 'd': + ret_val = RetDbl; /* returns C double */ + break; + case 'n': + ret_val = RetNoVal; /* returns nothing directly */ + break; + case 's': + ret_val = RetSig; /* returns a signal */ + break; + default: + db_err1(1, "invalid indicator for type of return value"); + } + + /* + * Get the return/suspend/fail/fall-through flag. + */ + c = getc(db); + ret_flag = db_rtflg(); + + /* + * Get the flag indicating whether the body function expects + * to have an explicit result location passed to it. + */ + c = getc(db); + SkipWhSp(c) + switch (c) { + case 't': + rslt = 1; + break; + case 'f': + rslt = 0; + break; + default: + db_err1(1, "t or f expected"); + } + + c = getc(db); + SkipWhSp(c) + GetInt(num_sbuf, c) /* number of cset buffers */ + c = getc(db); + SkipWhSp(c) + GetInt(num_cbuf, c) /* number of string buffers */ + c = getc(db); + SkipWhSp(c) + GetInt(n, c) /* num args */ + + il = new_il(IL_Call, 8 + n * 2); + il->u[0].n = 0; /* reserved for internal use by compiler */ + il->u[1].n = prfx3; + il->u[2].n = ret_val; + il->u[3].n = ret_flag; + il->u[4].n = rslt; + il->u[5].n = num_sbuf; + il->u[6].n = num_cbuf; + il->u[7].n = n; + indx = 8; + + /* + * get the prototype parameter declarations and actual arguments. + */ + n *= 2; + while (n--) + il->u[indx++].c_cd = db_ilc(); + } + break; + + case 'n': + if (getc(db) != 'v') + db_err1(1, "expected cnv1 or cnv2"); + switch (getc(db)) { + case '1': + il = new_il(IL_Cnv1, 2); + il->u[0].n = db_icntyp(); /* type code */ + il->u[1].fld = db_ilvar(); /* source */ + break; + case '2': + il = new_il(IL_Cnv2, 3); + il->u[0].n = db_icntyp(); /* type code */ + il->u[1].fld = db_ilvar(); /* source */ + il->u[2].c_cd = db_ilc(); /* destination */ + break; + default: + db_err1(1, "expected cnv1 or cnv2"); + } + break; + + case 'o': + db_chstr("co", "nst"); + il = new_il(IL_Const, 2); /* constant keyword */ + il->u[0].n = db_icntyp(); /* type code */ + c = getc(db); + SkipWhSp(c) + if (c == '"' || c == '\'') { + quoted(c); + c = getc(db); /* quoted literal without quotes */ + } + else + while (c != EOF && !isspace(c)) { + AppChar(db_sbuf, c); + c = getc(db); + } + il->u[1].s = str_install(&db_sbuf); /* non-quoted values */ + break; + + default: + db_err1(1, "expected call, const, cnv1, or cnv2"); + } + break; + + case 'd': + if (getc(db) != 'e' || getc(db) != 'f') + db_err1(1, "expected def1 or def2"); + switch (getc(db)) { + case '1': + il = new_il(IL_Def1, 3); /* defaulting, no dest. field */ + il->u[0].n = db_icntyp(); /* type code */ + il->u[1].fld = db_ilvar(); /* source */ + il->u[2].c_cd = db_ilc(); /* default value */ + break; + case '2': + il = new_il(IL_Def2, 4); /* defaulting, with dest. field */ + il->u[0].n = db_icntyp(); /* type code */ + il->u[1].fld = db_ilvar(); /* source */ + il->u[2].c_cd = db_ilc(); /* default value */ + il->u[3].c_cd = db_ilc(); /* destination */ + break; + default: + db_err1(1, "expected dflt1 or dflt2"); + } + break; + + case 'r': + if (getc(db) != 'u' || getc(db) != 'n' || getc(db) != 'e' || + getc(db) != 'r' || getc(db) != 'r') + db_err1(1, "expected runerr1 or runerr2"); + switch (getc(db)) { + case '1': + il = new_il(IL_Err1, 1); /* runerr, no offending value */ + c = getc(db); + SkipWhSp(c) + GetInt(n, c) + il->u[0].n = n; /* error number */ + break; + case '2': + il = new_il(IL_Err2, 2); /* runerr, with offending value */ + c = getc(db); + SkipWhSp(c) + GetInt(n, c) + il->u[0].n = n; /* error number */ + il->u[1].fld = db_ilvar(); /* variable */ + break; + default: + db_err1(1, "expected runerr1 or runerr2"); + } + break; + + case 'i': + switch (getc(db)) { + case 'f': + switch (getc(db)) { + case '1': + il = new_il(IL_If1, 2); /* if-then */ + il->u[0].fld = db_inlin(); /* condition */ + il->u[1].fld = db_inlin(); /* then clause */ + break; + case '2': + il = new_il(IL_If2, 3); /* if-then-else */ + il->u[0].fld = db_inlin(); /* condition */ + il->u[1].fld = db_inlin(); /* then clause */ + il->u[2].fld = db_inlin(); /* else clause */ + break; + default: + db_err1(1, "expected if1 or if2"); + } + break; + case 's': + il = new_il(IL_Is, 2); /* type check */ + il->u[0].n = db_icntyp(); /* type code */ + il->u[1].fld = db_ilvar(); /* variable */ + break; + default: + db_err1(1, "expected if1, if2, or is"); + } + break; + + case 'l': + switch (getc(db)) { + case 'c': + db_chstr("lc", "ase"); + c = getc(db); + SkipWhSp(c) + GetInt(n, c) + il = new_il(IL_Lcase, 2 + 2 * n); /* length case */ + il->u[0].n = n; /* number of cases */ + indx = 1; + while (n--) { + c = getc(db); + SkipWhSp(c) + GetInt(n1, c) + il->u[indx++].n = n1; /* selection number */ + il->u[indx++].fld = db_inlin(); /* action */ + } + il->u[indx].fld = db_inlin(); /* default */ + break; + + case 's': + if (getc(db) != 't') + db_err1(1, "expected lst"); + il = new_il(IL_Lst, 2); /* sequence of code parts */ + il->u[0].fld = db_inlin(); /* 1st part */ + il->u[1].fld = db_inlin(); /* 2nd part */ + break; + + default: + db_err1(1, "expected lcase or lst"); + } + break; + + case 'n': + db_chstr("n", "il"); + il = NULL; + break; + + case 't': { + struct il_code *var; + + if (getc(db) != 'c' || getc(db) != 'a' || getc(db) != 's' || + getc(db) != 'e') + db_err1(1, "expected tcase1 or tcase2"); + switch (getc(db)) { + case '1': + var = db_ilvar(); + c = getc(db); + SkipWhSp(c) + GetInt(n, c) + il = new_il(IL_Tcase1, 3 * n + 2); /* type case, no default */ + il->u[0].fld = var; /* variable */ + db_case(il, n); /* get cases */ + break; + + case '2': + var = db_ilvar(); + c = getc(db); + SkipWhSp(c) + GetInt(n, c) + il = new_il(IL_Tcase2, 3 * n + 3); /* type case, with default */ + il->u[0].fld = var; /* variable */ + db_case(il, n); /* get cases */ + il->u[3 * n + 2].fld = db_inlin(); /* default */ + break; + + default: + db_err1(1, "expected tcase1 or tcase2"); + } + } + break; + + case '!': + il = new_il(IL_Bang, 1); /* negated condition */ + il->u[0].fld = db_inlin(); /* condition */ + break; + + case '&': + if (getc(db) != '&') + db_err1(1, "expected &&"); + il = new_il(IL_And, 2); /* && (conjunction) */ + il->u[0].fld = db_inlin(); /* 1st operand */ + il->u[1].fld = db_inlin(); /* 2nd operand */ + break; + + default: + db_err1(1, "syntax error"); + } + return il; + } + +/* + * db_rtflg - get the sequence of 4 [or 5] flags that indicate whether code + * for a operation [or body function] returns, fails, suspends, has error + * failure, [or execution falls through the code]. + */ +static int db_rtflg() + { + register int c; + int ret_flag; + + /* + * The presence of each flag is indicated by a unique character. Its absence + * indicated by '_'. + */ + ret_flag = 0; + c = getc(db); + SkipWhSp(c) + if (c == 'f') + ret_flag |= DoesFail; + else if (c != '_') + db_err1(1, "invalid return indicator"); + c = getc(db); + if (c == 'r') + ret_flag |= DoesRet; + else if (c != '_') + db_err1(1, "invalid return indicator"); + c = getc(db); + if (c == 's') + ret_flag |= DoesSusp; + else if (c != '_') + db_err1(1, "invalid return indicator"); + c = getc(db); + if (c == 'e') + ret_flag |= DoesEFail; + else if (c != '_') + db_err1(1, "invalid return indicator"); + c = getc(db); + if (c == 't') + ret_flag |= DoesFThru; + else if (c != '_' && c != ' ') + db_err1(1, "invalid return indicator"); + return ret_flag; + } + +/* + * db_case - get the cases for a type_case statement from the data base. + */ +static void db_case(il, num_cases) +struct il_code *il; +int num_cases; + { + register int c; + int *typ_vect; + int i, j; + int num_types; + int indx; + + il->u[1].n = num_cases; /* number of cases */ + indx = 2; + for (i = 0; i < num_cases; ++i) { + /* + * Determine the number of types in this case then store the + * type codes in an array. + */ + c = getc(db); + SkipWhSp(c) + GetInt(num_types, c) + il->u[indx++].n = num_types; + typ_vect = alloc(num_types * sizeof(int)); + il->u[indx++].vect = typ_vect; + for (j = 0; j < num_types; ++j) + typ_vect[j] = db_icntyp(); /* type code */ + + il->u[indx++].fld = db_inlin(); /* action */ + } + } + +/* + * db_ilvar - get a symbol table index for a simple variable or a + * subscripted variable from the data base. + */ +static struct il_code *db_ilvar() + { + struct il_code *il; + register int c; + int n; + + c = getc(db); + SkipWhSp(c) + + if (isdigit(c)) { + /* + * Simple variable: just a symbol table index. + */ + il = new_il(IL_Var, 1); + GetInt(n, c) + il->u[0].n = n; /* symbol table index */ + } + else { + if (c != '[') + db_err1(1, "expected symbol table index or '['"); + /* + * Subscripted variable: symbol table index and subscript. + */ + il = new_il(IL_Subscr, 2); + c = getc(db); + SkipWhSp(c); + GetInt(n, c) + il->u[0].n = n; /* symbol table index */ + c = getc(db); + SkipWhSp(c) + GetInt(n, c) + il->u[1].n = n; /* subscripting index */ + } + return il; + } + +/* + * db_abstr - get abstract type computations from the data base. + */ +static struct il_code *db_abstr() + { + struct il_code *il = NULL; + register int c; + word typcd; + word indx; + int n; + int nargs; + + c = getc(db); + SkipWhSp(c) + switch (c) { + case 'l': + db_chstr("l", "st"); + il = new_il(IL_Lst, 2); /* sequence of code parts */ + il->u[0].fld = db_abstr(); /* 1st part */ + il->u[1].fld = db_abstr(); /* 2nd part */ + break; + + case 'n': + switch (getc(db)) { + case 'e': + if (getc(db) != 'w') + db_err1(1, "expected new"); + typcd = db_icntyp(); + c = getc(db); + SkipWhSp(c) + GetInt(nargs, c) + il = new_il(IL_New, 2 + nargs); /* new structure create here */ + il->u[0].n = typcd; /* type code */ + il->u[1].n = nargs; /* number of args */ + indx = 2; + while (nargs--) + il->u[indx++].fld = db_abstr(); /* argument for component */ + break; + case 'i': + if (getc(db) != 'l') + db_err1(1, "expected nil"); + il = NULL; + break; + default: + db_err1(1, "expected new or nil"); + } + break; + + case 's': + db_chstr("s", "tore"); + il = new_il(IL_Store, 1); /* abstract store */ + il->u[0].fld = db_abstr(); /* type to "dereference" */ + break; + + case 't': + db_chstr("t", "yp"); + il = new_il(IL_IcnTyp, 1); /* explicit type */ + il->u[0].n = db_icntyp(); /* type code */ + break; + + case 'v': + db_chstr("v", "artyp"); + il = new_il(IL_VarTyp, 1); /* variable */ + il->u[0].fld = db_ilvar(); /* symbol table index, etc */ + break; + + case '.': + il = new_il(IL_Compnt, 2); /* component access */ + il->u[0].fld = db_abstr(); /* type being accessed */ + c = getc(db); + SkipWhSp(c) + switch (c) { + case 'f': + il->u[1].n = CM_Fields; + break; + case 'C': + c = getc(db); + GetInt(n, c) + il->u[1].n = compnt_map[n]; + break; + default: + db_err1(1, "expected component code"); + } + break; + + case '=': + il = new_il(IL_TpAsgn, 2); /* assignment (side effect) */ + il->u[0].fld = db_abstr(); /* left-hand-side */ + il->u[1].fld = db_abstr(); /* right-hand-side */ + break; + + case '+': + if (getc(db) != '+') + db_err1(1, "expected ++"); + il = new_il(IL_Union, 2); /* ++ (union) */ + il->u[0].fld = db_abstr(); /* 1st operand */ + il->u[1].fld = db_abstr(); /* 2nd operand */ + break; + + case '*': + if (getc(db) != '*') + db_err1(1, "expected **"); + il = new_il(IL_Inter, 2); /* ** (intersection) */ + il->u[0].fld = db_abstr(); /* 1st operand */ + il->u[1].fld = db_abstr(); /* 2nd operand */ + break; + } + return il; + } + +/* + * db_ilc - read a piece of in-line C code. + */ +static struct il_c *db_ilc() + { + register int c; + int old_c; + word n; + struct il_c *base = NULL; + struct il_c **nxtp = &base; + + c = getc(db); + SkipWhSp(c) + switch (c) { + case '$': + /* + * This had better be the starting $c. + */ + c = getc(db); + if (c == 'c') { + c = getc(db); + for (;;) { + SkipWhSp(c) + if (c == '$') { + c = getc(db); + switch (c) { + case 'c': /* $cb or $cgoto */ + c = getc(db); + switch (c) { + case 'b': + *nxtp = new_ilc(ILC_CBuf); + c = getc(db); + break; + case 'g': + db_chstr("$cg", "oto"); + *nxtp = new_ilc(ILC_CGto); +#ifdef MultiThread + #undef code +#endif /* MultiThead */ + (*nxtp)->code[0] = db_ilc(); + c = getc(db); + SkipWhSp(c); + if (!isdigit(c)) + db_err1(1, "$cgoto: expected label number"); + GetInt(n, c); + (*nxtp)->n = n; + break; + default: + db_err1(1, "expected $cb or $cgoto"); + } + break; + case 'e': + c = getc(db); + if (c == 'f') { /* $efail */ + db_chstr("$ef", "ail"); + *nxtp = new_ilc(ILC_EFail); + c = getc(db); + break; + } + else + return base; /* $e */ + case 'f': /* $fail */ + db_chstr("$f", "ail"); + *nxtp = new_ilc(ILC_Fail); + c = getc(db); + break; + case 'g': /* $goto */ + db_chstr("$g", "oto"); + *nxtp = new_ilc(ILC_Goto); + c = getc(db); + SkipWhSp(c); + if (!isdigit(c)) + db_err1(1, "$goto: expected label number"); + GetInt(n, c); + (*nxtp)->n = n; + break; + case 'l': /* $lbl */ + db_chstr("$l", "bl"); + *nxtp = new_ilc(ILC_Lbl); + c = getc(db); + SkipWhSp(c); + if (!isdigit(c)) + db_err1(1, "$lbl: expected label number"); + GetInt(n, c); + (*nxtp)->n = n; + break; + case 'm': /* $m[d] */ + *nxtp = new_ilc(ILC_Mod); + c = getc(db); + if (c == 'd') { + (*nxtp)->s = "d"; + c = getc(db); + } + if (isdigit(c)) { + GetInt(n, c); + (*nxtp)->n = n; + } + else if (c == 'r') { + (*nxtp)->n = RsltIndx; + c = getc(db); + } + else + db_err1(1, "$m: expected symbol table index"); + break; + case 'r': /* $r[d] or $ret ... */ + c = getc(db); + if (isdigit(c) || c == 'd') { + *nxtp = new_ilc(ILC_Ref); + if (c == 'd') { + (*nxtp)->s = "d"; + c = getc(db); + } + GetInt(n, c); + (*nxtp)->n = n; + } + else if (c == 'r') { + *nxtp = new_ilc(ILC_Ref); + (*nxtp)->n = RsltIndx; + c = getc(db); + } + else { + if (c != 'e' || getc(db) != 't') + db_err1(1, "expected $ret"); + *nxtp = db_ilcret(ILC_Ret); + c = getc(db); + } + break; + case 's': /* $sb or $susp ... */ + c = getc(db); + switch (c) { + case 'b': + *nxtp = new_ilc(ILC_SBuf); + c = getc(db); + break; + case 'u': + db_chstr("$su", "sp"); + *nxtp = db_ilcret(ILC_Susp); + c = getc(db); + break; + default: + db_err1(1, "expected $sb or $susp"); + } + break; + case 't': /* $t[d] */ + *nxtp = new_ilc(ILC_Tend); + c = getc(db); + if (!isdigit(c)) + db_err1(1, "$t: expected index"); + GetInt(n, c); + (*nxtp)->n = n; + break; + case '{': + *nxtp = new_ilc(ILC_LBrc); + c = getc(db); + break; + case '}': + *nxtp = new_ilc(ILC_RBrc); + c = getc(db); + break; + default: + db_err1(1, "invalid $ escape in C code"); + } + } + else { + /* + * Arbitrary code - gather into a string. + */ + while (c != '$') { + if (c == '"' || c == '\'') { + quoted(c); + c = getc(db); + } + if (c == '\n') + ++dbline; + if (c == EOF) + db_err1(1, "unexpected EOF in C code"); + old_c = c; + AppChar(db_sbuf, c); + c = getc(db); + if (old_c == ' ') + while (c == ' ') + c = getc(db); + } + *nxtp = new_ilc(ILC_Str); + (*nxtp)->s = str_install(&db_sbuf); + } + nxtp = &(*nxtp)->next; + } + } + break; + case 'n': + db_chstr("n", "il"); + return NULL; + } + db_err1(1, "expected C code of the form $c ... $e or nil"); + /*NOTREACHED*/ + return 0; /* avoid gcc warning */ + } + +/* + * quoted - get the string for a quoted literal. The first quote mark + * has been read. + */ +static void quoted(delim) +int delim; + { + register int c; + + AppChar(db_sbuf, delim); + c = getc(db); + while (c != delim && c != EOF) { + if (c == '\\') { + AppChar(db_sbuf, c); + c = getc(db); + if (c == EOF) + db_err1(1, "unexpected EOF in quoted literal"); + } + AppChar(db_sbuf, c); + c = getc(db); + } + if (c == EOF) + db_err1(1, "unexpected EOF in quoted literal"); + AppChar(db_sbuf, c); + } + +/* + * db_ilcret - get the in-line C code on a return or suspend statement. + */ +static struct il_c *db_ilcret(il_c_type) +int il_c_type; + { + struct il_c *ilc; + int c; + int n; + int i; + + ilc = new_ilc(il_c_type); + ilc->n = db_icntyp(); /* kind of return expression */ + c = getc(db); + SkipWhSp(c) + GetInt(n, c) /* number of arguments in this expression */ + for (i = 0; i < n; ++i) + ilc->code[i] = db_ilc(); /* an argument to the return expression */ + return ilc; + } + +/* + * db_tndtyp - get the indication for the type of a tended declaration. + */ +static int db_tndtyp() + { + int c; + + c = getc(db); + SkipWhSp(c) + switch (c) { + case 'b': + db_chstr("b", "lkptr"); + return TndBlk; /* tended block pointer */ + case 'd': + db_chstr("d", "esc"); + return TndDesc; /* tended descriptor */ + case 's': + db_chstr("s", "tr"); + return TndStr; /* tended string */ + default: + db_err1(1, "expected blkptr, desc, or str"); + /* NOTREACHED */ + } + /* NOTREACHED */ + return 0; /* avoid gcc warning */ + } + +/* + * db_icntyp - get a type code from the data base. + */ +static int db_icntyp() + { + int c; + int n; + + c = getc(db); + SkipWhSp(c) + switch (c) { + case 'T': + c = getc(db); + GetInt(n, c) + if (n < num_typs) + return type_map[n]; /* type code from specification system */ + break; + case 'a': + return TypAny; /* a - any type */ + case 'c': + switch (getc(db)) { + case 'i': + return TypCInt; /* ci - C integer */ + case 'd': + return TypCDbl; /* cd - C double */ + case 's': + return TypCStr; /* cs - C string */ + } + break; + case 'd': + return RetDesc; /* d - descriptor on return statement */ + case 'e': + switch (getc(db)) { + case 'c': + if (getc(db) == 'i') + return TypECInt; /* eci - exact C integer */ + break; + case 'i': + return TypEInt; /* ei - exact integer */ + case ' ': + case '\n': + case '\t': + return TypEmpty; /* e - empty type */ + } + break; + case 'n': + if (getc(db) == 'v') + return RetNVar; /* nv - named variable on return */ + break; + case 'r': + if (getc(db) == 'n') + return RetNone; /* rn - nothing explicitly returned */ + break; + case 's': + if (getc(db) == 'v') + return RetSVar; /* sv - structure variable on return */ + break; + case 't': + switch (getc(db)) { + case 'c': + return TypTCset; /* tc - temporary cset */ + case 's': + return TypTStr; /* ts - temporary string */ + } + break; + case 'v': + return TypVar; /* v - variable */ + } + db_err1(1, "invalid type code"); + /* NOTREACHED */ + return 0; /* avoid gcc warning */ + } + +/* + * new_ilc - allocate a new structure to hold a piece of in-line C code. + */ +static struct il_c *new_ilc(il_c_type) +int il_c_type; + { + struct il_c *ilc; + int i; + + ilc = NewStruct(il_c); + ilc->next = NULL; + ilc->il_c_type = il_c_type; + for (i = 0; i < 3; ++i) + ilc->code[i] = NULL; + ilc->n = 0; + ilc->s = NULL; + return ilc; + } + +/* + * new_il - allocate a new structure with "size" fields to hold a piece of + * RTL code. + */ +struct il_code *new_il(il_type, size) +int il_type; +int size; + { + struct il_code *il; + + il = alloc(sizeof(struct il_code) + (size-1) * sizeof(union il_fld)); + il->il_type = il_type; + return il; + } + +/* + * db_dscrd - discard an implementation up to $end, skipping the in-line + * RTL code. + */ +void db_dscrd(ip) +struct implement *ip; + { + char state; /* how far along we are at recognizing $end */ + + free(ip); + state = '\0'; + for (;;) { + switch (getc(db)) { + case '$': + state = '$'; + continue; + case 'e': + if (state == '$') { + state = 'e'; + continue; + } + break; + case 'n': + if (state == 'e') { + state = 'n'; + continue; + } + break; + case 'd': + if (state == 'n') + return; + break; + case '\n': + ++dbline; + break; + case EOF: + db_err1(1, "unexpected EOF"); + } + state = '\0'; + } + } + +/* + * db_chstr - we are expecting a specific string. We may already have + * read a prefix of it. + */ +void db_chstr(prefix, suffix) +char *prefix; +char *suffix; + { + int c; + + c = getc(db); + SkipWhSp(c) + + for (;;) { + if (*suffix == '\0' && (isspace(c) || c == EOF)) { + if (c == '\n') + ++dbline; + return; + } + else if (*suffix != c) + break; + c = getc(db); + ++suffix; + } + db_err3(1, "expected:", prefix, suffix); + } + +/* + * db_tbl - fill in a hash table of implementation information for the + * given section. + */ +int db_tbl(section, tbl) +char *section; +struct implement **tbl; + { + struct implement *ip; + int num_added = 0; + unsigned hashval; + + /* + * Get past the section header. + */ + db_chstr("", section); + + /* + * Create an entry in the hash table for each entry in the data base. + * If multiple data bases are loaded into one hash table, use the + * first entry encountered for each operation. + */ + while ((ip = db_impl(toupper(section[0]))) != NULL) { + if (db_ilkup(ip->name, tbl) == NULL) { + db_code(ip); + hashval = IHasher(ip->name); + ip->blink = tbl[hashval]; + tbl[hashval] = ip; + ++num_added; + db_chstr("", "end"); + } + else + db_dscrd(ip); + } + db_chstr("", "endsect"); + return num_added; + } + +/* + * db_ilkup - look up id in a table of implementation information and return + * pointer it or NULL if it is not there. + */ +struct implement *db_ilkup(id, tbl) +char *id; +struct implement **tbl; + { + register struct implement *ptr; + + ptr = tbl[IHasher(id)]; + while (ptr != NULL && ptr->name != id) + ptr = ptr->blink; + return ptr; + } + +/* + * nxt_pre - assign next prefix. A prefix consists of n characters each from + * the range 0-9 and a-z, at least one of which is a digit. + * + */ +void nxt_pre(pre, nxt, n) +char *pre; +char *nxt; +int n; + { + int i, num_dig; + + if (nxt[0] == '\0') { + fprintf(stderr, "out of unique prefixes\n"); + exit(EXIT_FAILURE); + } + + /* + * copy the next prefix into the output string. + */ + for (i = 0; i < n; ++i) + pre[i] = nxt[i]; + + /* + * Increment next prefix. First, determine how many digits there are in + * the current prefix. + */ + num_dig = 0; + for (i = 0; i < n; ++i) + if (isdigit(nxt[i])) + ++num_dig; + + for (i = n - 1; i >= 0; --i) { + switch (nxt[i]) { + case '9': + /* + * If there is at least one other digit, increment to a letter. + * Otherwise, start over at zero and continue to the previous + * character in the prefix. + */ + if (num_dig > 1) { + nxt[i] = 'a'; + return; + } + else + nxt[i] = '0'; + break; + + case 'z': + /* + * Start over at zero and continue to previous character in the + * prefix. + */ + nxt[i] = '0'; + ++num_dig; + break; + default: + ++nxt[i]; + return; + } + } + + /* + * Indicate that there are no more prefixes. + */ + nxt[0] = '\0'; + } + +/* + * cmp_pre - lexically compare 2-character prefixes. + */ +int cmp_pre(pre1, pre2) +char *pre1; +char *pre2; + { + int cmp; + + cmp = cmp_1_pre(pre1[0], pre2[0]); + if (cmp == 0) + return cmp_1_pre(pre1[1], pre2[1]); + else + return cmp; + } + +/* + * cmp_1_pre - lexically compare 1 character of a prefix. + */ +static int cmp_1_pre(p1, p2) +int p1; +int p2; + { + if (isdigit(p1)) { + if (isdigit(p2)) + return p1 - p2; + else + return -1; + } + else { + if (isdigit(p2)) + return 1; + else + return p1 - p2; + } + } + +/* + * db_err1 - print a data base error message in the form of 1 string. + */ +void db_err1(fatal, s) +int fatal; +char *s; + { + if (fatal) + fprintf(stderr, "error, "); + else + fprintf(stderr, "warning, "); + fprintf(stderr, "data base \"%s\", line %d - %s\n", dbname, dbline, s); + if (fatal) + exit(EXIT_FAILURE); + } + +/* + * db_err2 - print a data base error message in the form of 2 strings. + */ +void db_err2(fatal, s1, s2) +int fatal; +char *s1; +char *s2; + { + if (fatal) + fprintf(stderr, "error, "); + else + fprintf(stderr, "warning, "); + fprintf(stderr, "data base \"%s\", line %d - %s %s\n", dbname, dbline, s1, + s2); + if (fatal) + exit(EXIT_FAILURE); + } + +/* + * db_err3 - print a data base error message in the form of 3 strings. + */ +static void db_err3(fatal, s1, s2, s3) +int fatal; +char *s1; +char *s2; +char *s3; + { + if (fatal) + fprintf(stderr, "error, "); + else + fprintf(stderr, "warning, "); + fprintf(stderr, "data base \"%s\", line %d - %s %s%s\n", dbname, dbline, s1, + s2, s3); + if (fatal) + exit(EXIT_FAILURE); + } diff --git a/src/common/strtbl.c b/src/common/strtbl.c new file mode 100644 index 0000000..129dc94 --- /dev/null +++ b/src/common/strtbl.c @@ -0,0 +1,207 @@ +/* + * The functions in this file maintain a hash table of strings and manage + * string buffers. + */ +#include "../h/gsupport.h" + +/* + * Prototype for static function. + */ +static int streq (int len, char *s1, char *s2); + +/* + * Entry in string table. + */ +struct str_entry { + char *s; /* string */ + int length; /* length of string */ + struct str_entry *next; + }; + +#define SBufSize 1024 /* initial size of a string buffer */ +#define StrTblSz 149 /* size of string hash table */ +static struct str_entry **str_tbl = NULL; /* string hash table */ + +/* + * init_str - initialize string hash table. + */ +void init_str() + { + int h; + + if (str_tbl == NULL) { + str_tbl = alloc(StrTblSz * sizeof(struct str_entry *)); + for (h = 0; h < StrTblSz; ++h) + str_tbl[h] = NULL; + } + } + +/* + * free_stbl - free string table. + */ +void free_stbl() + { + struct str_entry *se, *se1; + int h; + + for (h = 0; h < StrTblSz; ++h) + for (se = str_tbl[h]; se != NULL; se = se1) { + se1 = se->next; + free((char *)se); + } + + free((char *)str_tbl); + str_tbl = NULL; + } + +/* + * init_sbuf - initialize a new sbuf struct, allocating an initial buffer. + */ +void init_sbuf(sbuf) +struct str_buf *sbuf; + { + sbuf->size = SBufSize; + sbuf->frag_lst = alloc(sizeof(struct str_buf_frag) + (SBufSize - 1)); + sbuf->frag_lst->next = NULL; + sbuf->strtimage = sbuf->frag_lst->s; + sbuf->endimage = sbuf->strtimage; + sbuf->end = sbuf->strtimage + SBufSize; + } + +/* + * clear_sbuf - free string buffer storage. + */ +void clear_sbuf(sbuf) +struct str_buf *sbuf; + { + struct str_buf_frag *sbf, *sbf1; + + for (sbf = sbuf->frag_lst; sbf != NULL; sbf = sbf1) { + sbf1 = sbf->next; + free((char *)sbf); + } + sbuf->frag_lst = NULL; + sbuf->strtimage = NULL; + sbuf->endimage = NULL; + sbuf->end = NULL; + } + +/* + * new_sbuf - allocate a new buffer for a sbuf struct, copying the partially + * created string from the end of full buffer to the new one. + */ +void new_sbuf(sbuf) +struct str_buf *sbuf; + { + struct str_buf_frag *sbf; + char *s1, *s2; + + /* + * The new buffer is larger than the old one to insure that any + * size string can be buffered. + */ + sbuf->size *= 2; + s1 = sbuf->strtimage; + sbf = alloc(sizeof(struct str_buf_frag) + (sbuf->size - 1)); + sbf->next = sbuf->frag_lst; + sbuf->frag_lst = sbf; + sbuf->strtimage = sbf->s; + s2 = sbuf->strtimage; + while (s1 < sbuf->endimage) + *s2++ = *s1++; + sbuf->endimage = s2; + sbuf->end = sbuf->strtimage + sbuf->size; + } + +/* + * spec_str - install a special string (null terminated) in the string table. + */ +char *spec_str(s) +char *s; + { + struct str_entry *se; + register char *s1; + register int l; + register int h; + + h = 0; + l = 1; + for (s1 = s; *s1 != '\0'; ++s1) { + h += *s1 & 0377; + ++l; + } + h %= StrTblSz; + for (se = str_tbl[h]; se != NULL; se = se->next) + if (l == se->length && streq(l, s, se->s)) + return se->s; + se = NewStruct(str_entry); + se->s = s; + se->length = l; + se->next = str_tbl[h]; + str_tbl[h] = se; + return s; + } + +/* + * str_install - find out if the string at the end of the buffer is in + * the string table. If not, put it there. Return a pointer to the + * string in the table. + */ +char *str_install(sbuf) +struct str_buf *sbuf; + { + int h; + struct str_entry *se; + register char *s; + register char *e; + int l; + + AppChar(*sbuf, '\0'); /* null terminate the buffered copy of the string */ + s = sbuf->strtimage; + e = sbuf->endimage; + + /* + * Compute hash value. + */ + h = 0; + while (s < e) + h += *s++ & 0377; + h %= StrTblSz; + s = sbuf->strtimage; + l = e - s; + for (se = str_tbl[h]; se != NULL; se = se->next) + if (l == se->length && streq(l, s, se->s)) { + /* + * A copy of the string is already in the table. Delete the copy + * in the buffer. + */ + sbuf->endimage = s; + return se->s; + } + + /* + * The string is not in the table. Add the copy from the buffer to the + * table. + */ + se = NewStruct(str_entry); + se->s = s; + se->length = l; + sbuf->strtimage = e; + se->next = str_tbl[h]; + str_tbl[h] = se; + return se->s; + } + +/* + * streq - compare s1 with s2 for len bytes, and return 1 for equal, + * 0 for not equal. + */ +static int streq(len, s1, s2) +register int len; +register char *s1, *s2; + { + while (len--) + if (*s1++ != *s2++) + return 0; + return 1; + } diff --git a/src/common/time.c b/src/common/time.c new file mode 100644 index 0000000..84d8fe1 --- /dev/null +++ b/src/common/time.c @@ -0,0 +1,34 @@ +#include "../h/gsupport.h" + +/* + * millisec - returns execution time in milliseconds. Time is measured + * from the function's first call. The granularity of the time is + * generally larger than one millisecond and on some systems it may + * only be accurate to the second. + * + * For some unfathomable reason, the Open Group's "Single Unix Specification" + * requires that the ANSI C clock() function be defined in units of 1/1000000 + * second. This means that the result overflows a 32-bit signed clock_t + * value only about 35 minutes. Consequently, we use the POSIX standard + * times() function instead. + */ + +long millisec() + { + static long clockres = 0; + static long starttime = 0; + long curtime; + struct tms tp; + + times(&tp); + curtime = tp.tms_utime + tp.tms_stime; + if (clockres == 0) { + #ifdef CLK_TCK + clockres = CLK_TCK; + #else + clockres = sysconf(_SC_CLK_TCK); + #endif + starttime = curtime; + } + return (long) ((1000.0 / clockres) * (curtime - starttime)); + } diff --git a/src/common/tokens.txt b/src/common/tokens.txt new file mode 100644 index 0000000..c717d36 --- /dev/null +++ b/src/common/tokens.txt @@ -0,0 +1,76 @@ +Primitive Tokens + + Token Token Type Flags + + identifier IDENT b e + integer-literal INTLIT b e + real-literal REALLIT b e + string-literal STRINGLIT b e + cset-literal CSETLIT b e + end-of-file EOFX + +Reserved Words + + Token Token Type Flags + + break BREAK b e + by BY + case CASE b + create CREATE b + default DEFAULT b + do DO + else ELSE + end END b + every EVERY b + fail FAIL b e + global GLOBAL + if IF b + initial INITIAL b + invocable INVOCABLE + link LINK + local LOCAL b + next NEXT b e + not NOT b + of OF + procedure PROCEDURE + record RECORD + repeat REPEAT b + return RETURN b e + static STATIC b + suspend SUSPEND b e + then THEN + to TO + until UNTIL b + while WHILE b + +``Operator'' tokens not used in standard unary/binary syntax, see op.txt. + + Token Token Type Flags + + ( LPAREN b + ) RPAREN e + +: PCOLON + , COMMA + -: MCOLON + : COLON + ; SEMICOL + [ LBRACK b + ] RBRACK e + { LBRACE b + } RBRACE e + +tokens starting with $ are alternate spellings for some tokens + + $( LBRACE b + $) RBRACE e + $< LBRACK b + $> RBRACK e + +Explanation of Flags + + b indicates that the token may begin an expression. + e indicates that the token may end an expression. + + These two flags are used for semicolon insertion. If a line + ends with an "e" token, and the next token is a "b" token, + a semicolon is inserted between the two tokens. diff --git a/src/common/typespec.icn b/src/common/typespec.icn new file mode 100644 index 0000000..f86ba9a --- /dev/null +++ b/src/common/typespec.icn @@ -0,0 +1,482 @@ +# +# typespec - transform Icon type specifications into C tables. +# Specifications are read from standard input; tables are written +# to standard output. +# +# The grammar for the a type specifcation is: +# +# ::= : +# +# ::= simple | +# aggregate(, ... ) | +# variable +# +# ::= var | +# +# +# ::= initially | +# always +# +# ::= | ++ +# +# ::= | +# { } +# +# ::= | +# return block_pointer | +# return descriptor_pointer | +# return char_pointer | +# return C_integer + +# Information about an Icon type. +# +record icon_type( + id, # name of type + support_new, # supports RTL "new" construct + deref, # dereferencing needs + rtl_ret, # kind of RTL return supported if any + typ, # for variable: initial type + num_comps, # for aggregate: number of type components + compnts, # for aggregate: index of first component + abrv) # abreviation used for type tracing + +# Information about a component of an aggregate type. +# +record typ_compnt ( + id, # name of component + n, # position of component within type aggragate + var, # flag: this component is an Icon-level variable + aggregate, # index of type that owns the component + abrv) # abreviation used for type tracing + +record token(kind, image) + +global icontypes, typecompnt, type_indx, compnt_indx +global lex, line_num, saved_token, error_msg, prog_name + +procedure main() + local typ, tok, compnt, indx, x + + prog_name := "typespec" + lex := create tokenize_input() + + icontypes := [] + typecompnt := [] + + # + # Read each of the type specifications + # + while typ := icon_type(ident("may be EOF")) do { + # + # Check for abreviation + # + typ.abrv := opt_abrv(typ.id) + + if next_token().kind ~== ":" then + input_err("expected ':'") + + # + # See what kind of type this is + # + case ident() of { + "simple": { + typ.support_new := "0" + typ.deref := "DrfNone" + typ.num_comps := "0" + typ.compnts := "0" + } + + "aggregate": { + typ.support_new := "1" + typ.deref := "DrfNone" + + # + # get the component names for the type + # + typ.compnts := *typecompnt + if next_token().kind ~== "(" then + input_err("expected '('") + typ.num_comps := 0 + tok := next_token() + if tok.kind ~== "id" then + input_err("expected type component") + while tok.kind ~== ")" do { + # + # See if this component is an Icon variable. + # + if tok.image == "var" then { + compnt := typ_compnt(ident(), typ.num_comps, "1", *icontypes) + compnt.abrv := opt_abrv(compnt.id) + } + else + compnt := typ_compnt(tok.image, typ.num_comps, "0", + *icontypes) + + put(typecompnt, compnt) + typ.num_comps +:= 1 + + tok := next_token() + if tok.kind == "," then { + tok := next_token() + if tok.kind ~== "id" then + input_err("expected type component") + } + else if tok.kind ~== ")" then + input_err("expected type component") + } + } + + "variable": { + typ.support_new := "0" + typ.num_comps := "0" + typ.compnts := "0" + case ident() of { + "initially": + typ.deref := "DrfGlbl" + "always": + typ.deref := "DrfCnst" + default: + input_err("expected 'initially' or 'always'") + } + + # + # Get the initial type associated with the variable + # + typ.typ := [ident()] + tok := &null + while (tok := next_token("may be EOF")).kind == "++" do { + put(typ.typ, ident()) + tok := &null + } + saved_token := tok # put token back + } + default: + input_err("expected 'simple', 'aggregate', or 'variable'") + } + + # + # Check for an optional return clause + # + tok := &null + if (tok := next_token("may be EOF")).image == "return" then { + case next_token().image of { + "block_pointer": + typ.rtl_ret := "TRetBlkP" + "descriptor_pointer": + typ.rtl_ret := "TRetDescP" + "char_pointer": + typ.rtl_ret := "TRetCharP" + "C_integer": + typ.rtl_ret := "TRetCInt" + default: + input_err("expected vword type") + } + } + else { + typ.rtl_ret := "TRetNone" + saved_token := tok # put token back + } + + put(icontypes, typ) + } + + # + # Create tables of type and compontent indexes. + # + type_indx := table() + indx := -1 + every type_indx[(!icontypes).id] := (indx +:= 1) + compnt_indx := table() + indx := -1 + every compnt_indx[(!typecompnt).id] := (indx +:= 1) + + write("/*") + write(" * This file was generated by the program ", prog_name, ".") + write(" */") + write() + + # + # Locate the indexes of types with special semantics or which are + # explicitly needed by iconc. Output the indexes as assignments to + # variables. + # + indx := req_type("string") + icontypes[indx + 1].rtl_ret := "TRetSpcl" + write("int str_typ = ", indx, ";") + + indx := req_type("integer") + write("int int_typ = ", indx, ";") + + indx := req_type("record") + write("int rec_typ = ", indx, ";") + + indx := req_type("proc") + write("int proc_typ = ", indx, ";") + + indx := req_type("coexpr") + write("int coexp_typ = ", indx, ";") + + indx := req_type("tvsubs") + icontypes[indx + 1].deref := "DrfSpcl" + icontypes[indx + 1].rtl_ret := "TRetSpcl" + write("int stv_typ = ", indx, ";") + + indx := req_type("tvtbl") + icontypes[indx + 1].deref := "DrfSpcl" + write("int ttv_typ = ", indx, ";") + + indx := req_type("null") + write("int null_typ = ", indx, ";") + + indx := req_type("cset") + write("int cset_typ = ", indx, ";") + + indx := req_type("real") + write("int real_typ = ", indx, ";") + + indx := req_type("list") + write("int list_typ = ", indx, ";") + + indx := req_type("table") + write("int tbl_typ = ", indx, ";") + + # + # Output the type table. + # + write() + write("int num_typs = ", *icontypes, ";") + write("struct icon_type icontypes[", *icontypes, "] = {") + x := copy(icontypes) + output_typ(get(x)) + while typ := get(x) do { + write(",") + output_typ(typ) + } + write("};") + + # + # Locate the indexes of components which are explicitly needed by iconc. + # Output the indexes as assignments to variables. + # + write() + indx := req_compnt("str_var") + write("int str_var = ", indx, ";") + + indx := req_compnt("trpd_tbl") + write("int trpd_tbl = ", indx, ";") + + indx := req_compnt("lst_elem") + write("int lst_elem = ", indx, ";") + + indx := req_compnt("tbl_dflt") + write("int tbl_dflt = ", indx, ";") + + indx := req_compnt("tbl_val") + write("int tbl_val = ", indx, ";") + + # + # Output the component table. + # + write() + write("int num_cmpnts = ", *typecompnt, ";") + write("struct typ_compnt typecompnt[", *typecompnt, "] = {") + output_compnt(get(typecompnt)) + while compnt := get(typecompnt) do { + write(",") + output_compnt(compnt) + } + write("};") +end + +# +# ident - insure that next token is an identifier and return its image +# +procedure ident(may_be_eof) + local tok + + tok := next_token(may_be_eof) | fail + + if tok.kind == "id" then + return tok.image + else + input_err("expected identifier") +end + +# +# opt_abrv - look for an optional abreviation. If there is none, return the +# default value supplied by the caller. +# +procedure opt_abrv(abrv) + local tok + + tok := next_token("may be EOF") + if tok.kind == "{" then { + abrv := ident() + if next_token().kind ~== "}" then + input_err("expected '}'") + } + else + saved_token := tok # put token back + + return abrv +end + +# +# next_token - get the next token, looking to see if one was put back. +# +procedure next_token(may_be_eof) + local tok + + if \saved_token then { + tok := saved_token + saved_token := &null + return tok + } + else if tok := @lex then + return tok + else if \may_be_eof then + fail + else { + write(&errout, prog_name, ", unexpected EOF") + exit(1) + } +end + +# +# req_type - get the index of a required type. +# +procedure req_type(id) + local indx + + if indx := \type_indx[id] then + return indx + else { + write(&errout, prog_name, ", the type ", id, " is required") + exit(1) + } +end + +# +# req_compnt - get the index of a required component. +# +procedure req_compnt(id) + local indx + + if indx := \compnt_indx[id] then + return indx + else { + write(&errout, prog_name, ", the component ", id, " is required") + exit(1) + } +end + +# +# output_typ - output the table entry for a type. +# +procedure output_typ(typ) + local typ_str, s, indx + + writes(" {", image(typ.id), ", ", typ.support_new, ", ", typ.deref, ", ", + typ.rtl_ret, ", ") + if \typ.typ then { + typ_str := repl(".", *type_indx) + every s := !typ.typ do { + if s == "any_value" then { + every indx := 1 to *icontypes do { + if icontypes[indx].deref == "DrfNone" then + typ_str[indx] := icontypes[indx].abrv[1] + } + } + else if indx := \type_indx[s] + 1 then + typ_str[indx] := icontypes[indx].abrv[1] + else { + write(&errout, prog_name, ", the specification for ", typ.id, + " contains an illegal type: ", s) + exit(1) + } + } + writes(image(typ_str)) + } + else + writes("NULL") + writes(", ", typ.num_comps, ", ", typ.compnts, ", ", image(typ.abrv), ", ") + writes(image(map(typ.id[1], &lcase, &ucase) || typ.id[2:0]), "}") +end + +# +# output_compnt - output the table entry for a component. +# +procedure output_compnt(compnt) + writes(" {", image(compnt.id), ", ", compnt.n, ", ", compnt.var, ", ", + compnt.aggregate, ", ", image(\compnt.abrv) | "NULL", "}") +end + +# +# input_err - signal the lexical anaylser to print an error message about +# the last token +# +procedure input_err(msg) + error_msg := msg + @lex +end + +# +# tokenize_input - transform standard input into tokens and suspend them +# +procedure tokenize_input() + local line + + line_num := 0 + while line := read() do { + line_num +:= 1 + suspend line ? tokenize_line() + } + fail +end + +# +# tokenize_line - transform the subject of string scanning into tokens and +# suspend them +# +procedure tokenize_line() + local s, tok, save_pos + static id_chars + + initial id_chars := &letters ++ &digits ++ '_' + + repeat { + tab(many(' \t')) # skip white space + if ="#" | pos(0) then + fail # end of input on this line + + save_pos := &pos + + if any(&letters) then + tok := token("id", tab(many(id_chars))) + else if s := =(":" | "(" | "," | ")" | "++" | "{" | "}") then + tok := token(s, s) + else + err("unknown symbol") + + suspend tok + err(\error_msg, save_pos) # was the last token erroneous? + } +end + +# +# err - print an error message about the current string being scanned +# +procedure err(msg, save_pos) + local s, strt_msg + + tab(\save_pos) # error occured here + + strt_msg := prog_name || ", " || msg || "; line " || line_num || ": " + (s := image(tab(1))) & &fail # get front of line then undo tab + strt_msg ||:= s[1:-1] # strip ending quote from image + s := image(tab(0)) # get end of line + s := s[2:0] # strip first quote from image + write(&errout, strt_msg, s) + write(&errout, repl(" ", *strt_msg), "^") # show location of error + exit(1) +end diff --git a/src/common/typespec.txt b/src/common/typespec.txt new file mode 100644 index 0000000..6fdd726 --- /dev/null +++ b/src/common/typespec.txt @@ -0,0 +1,87 @@ +# This file contains Icon type specifications. + +# The first group of types have special semantics that are not completely +# captured by the specification system. + + + string{s}: simple + # special form of descriptor + # has RLT return construct with two arguments + + integer{i}: simple + # two kinds of dwords + + record{R}: simple # really special aggregate + return block_pointer + # special semantics for allocating sub-types + # different sub-types have different components + + proc: simple + return block_pointer + # special semantics for allocating sub-types + + coexpr{C}: simple + return block_pointer + # special semantics for allocating sub-types + + # sub-string trapped variables + tvsubs{sstv}: aggregate(str_var) + # has RTL return construct with three arguments + # variable type with special dereferencing semantics + + # table-element trapped variables + tvtbl{tetv}: aggregate(trpd_tbl) + return block_pointer + # variable type with special dereferencing semantics + + +# The second group of types are required by iconc but have no special +# semantics. + + null{n}: simple + + cset{c}: simple + return block_pointer + + real{r}: simple + return block_pointer + + list{L}: aggregate(var lst_elem{LE}) + return block_pointer + + table{T}: aggregate(tbl_key, var tbl_val{TV}, tbl_dflt) + return block_pointer + + +# The third group of types appear only in RTL code. They have no special +# semantics nor any special uses by iconc. + + file{f}: simple + return block_pointer + + set{S}: aggregate(set_elem) + return block_pointer + + # integer keyword variables: &random, &trace, &error + kywdint: variable always integer + return descriptor_pointer + + # &subject + kywdsubj: variable always string + return descriptor_pointer + + # &pos + kywdpos: variable always integer + return descriptor_pointer + + # &eventsource, &eventvalue, &eventcode + kywdevent: variable always any_value + return descriptor_pointer + + # &window + kywdwin: variable always file ++ null + return descriptor_pointer + + # &fg and friends + kywdstr: variable always string + return descriptor_pointer diff --git a/src/common/xwindow.c b/src/common/xwindow.c new file mode 100644 index 0000000..b5d2c5b --- /dev/null +++ b/src/common/xwindow.c @@ -0,0 +1,159 @@ +/* + * xwindow.c - X Window System-specific routines + */ +#include "../h/define.h" +#include "../h/config.h" +#ifdef XWindows + +typedef struct { + char *s; + int i; +} stringint, *siptr; + +#ifdef XpmFormat + #include "../xpm/xpm.h" +#else /* XpmFormat */ + #include + #include +#endif /* XpmFormat */ + +#include +#include +#include +#include + +int GraphicsHome = XK_Home; +int GraphicsLeft = XK_Left; +int GraphicsUp = XK_Up; +int GraphicsRight = XK_Right; +int GraphicsDown = XK_Down; +int GraphicsPrior = XK_Prior; +int GraphicsNext = XK_Next; +int GraphicsEnd = XK_End; + +/* + * Translate a key event. Put ascii result if any in s. + * Return number of ascii (>0) if the key was "normal" and s is filled in. + * Return 0 if the key was strange and keysym should be returned. + * Return -1 if the key was a modifier key and should be dropped. + */ +int translate_key_event(event, s, k) +XKeyEvent *event; +char *s; +KeySym *k; +{ + int i = XLookupString(event, s, 10, k, NULL); + + if (i > 0) + return i; /* "normal" key */ + else if (IsModifierKey(*k)) + return -1; /* modifier key */ + else + return 0; /* other (e.g. function key) */ +} + +stringint drawops[] = { + { 0, 16}, + {"and", GXand}, + {"andInverted", GXandInverted}, + {"andReverse", GXandReverse}, + {"clear", GXclear}, + {"copy", GXcopy}, + {"copyInverted", GXcopyInverted}, + {"equiv", GXequiv}, + {"invert", GXinvert}, + {"nand", GXnand}, + {"noop", GXnoop}, + {"nor", GXnor}, + {"or", GXor}, + {"orInverted", GXorInverted}, + {"orReverse", GXorReverse}, + {"set", GXset}, + {"xor", GXxor}, +}; + +#define NUMCURSORSYMS 78 + +stringint cursorsyms[] = { + { 0, NUMCURSORSYMS}, + {"X cursor", XC_X_cursor}, + {"arrow", XC_arrow}, + {"based arrow down", XC_based_arrow_down}, + {"based arrow up", XC_based_arrow_up}, + {"boat", XC_boat}, + {"bogosity", XC_bogosity}, + {"bottom left corner",XC_bottom_left_corner}, + {"bottom right corner",XC_bottom_right_corner}, + {"bottom side", XC_bottom_side}, + {"bottom tee", XC_bottom_tee}, + {"box spiral", XC_box_spiral}, + {"center ptr", XC_center_ptr}, + {"circle", XC_circle}, + {"clock", XC_clock}, + {"coffee mug", XC_coffee_mug}, + {"cross", XC_cross}, + {"cross reverse", XC_cross_reverse}, + {"crosshair", XC_crosshair}, + {"diamond cross", XC_diamond_cross}, + {"dot", XC_dot}, + {"dotbox", XC_dotbox}, + {"double arrow", XC_double_arrow}, + {"draft large", XC_draft_large}, + {"draft small", XC_draft_small}, + {"draped box", XC_draped_box}, + {"exchange", XC_exchange}, + {"fleur", XC_fleur}, + {"gobbler", XC_gobbler}, + {"gumby", XC_gumby}, + {"hand1", XC_hand1}, + {"hand2", XC_hand2}, + {"heart", XC_heart}, + {"icon", XC_icon}, + {"iron cross", XC_iron_cross}, + {"left ptr", XC_left_ptr}, + {"left side", XC_left_side}, + {"left tee", XC_left_tee}, + {"leftbutton", XC_leftbutton}, + {"ll angle", XC_ll_angle}, + {"lr angle", XC_lr_angle}, + {"man", XC_man}, + {"middlebutton", XC_middlebutton}, + {"mouse", XC_mouse}, + {"pencil", XC_pencil}, + {"pirate", XC_pirate}, + {"plus", XC_plus}, + {"question arrow", XC_question_arrow}, + {"right ptr", XC_right_ptr}, + {"right side", XC_right_side}, + {"right tee", XC_right_tee}, + {"rightbutton", XC_rightbutton}, + {"rtl logo", XC_rtl_logo}, + {"sailboat", XC_sailboat}, + {"sb down arrow", XC_sb_down_arrow}, + {"sb h double arrow", XC_sb_h_double_arrow}, + {"sb left arrow", XC_sb_left_arrow}, + {"sb right arrow", XC_sb_right_arrow}, + {"sb up arrow", XC_sb_up_arrow}, + {"sb v double arrow", XC_sb_v_double_arrow}, + {"shuttle", XC_shuttle}, + {"sizing", XC_sizing}, + {"spider", XC_spider}, + {"spraycan", XC_spraycan}, + {"star", XC_star}, + {"target", XC_target}, + {"tcross", XC_tcross}, + {"top left arrow", XC_top_left_arrow}, + {"top left corner", XC_top_left_corner}, + {"top right corner", XC_top_right_corner}, + {"top side", XC_top_side}, + {"top tee", XC_top_tee}, + {"trek", XC_trek}, + {"ul angle", XC_ul_angle}, + {"umbrella", XC_umbrella}, + {"ur angle", XC_ur_angle}, + {"watch", XC_watch}, + {"xterm", XC_xterm}, + {"num glyphs", XC_num_glyphs}, +}; + +#endif /* XWindows */ diff --git a/src/common/yacctok.h b/src/common/yacctok.h new file mode 100644 index 0000000..a6a532d --- /dev/null +++ b/src/common/yacctok.h @@ -0,0 +1,125 @@ +/* + * NOTE: these %token declarations are generated + * automatically by mktoktab from tokens.txt and + * op.txt. + */ + +/* primitive tokens */ + +%token IDENT +%token INTLIT +%token REALLIT +%token STRINGLIT +%token CSETLIT +%token EOFX + +/* reserved words */ + +%token BREAK /* break */ +%token BY /* by */ +%token CASE /* case */ +%token CREATE /* create */ +%token DEFAULT /* default */ +%token DO /* do */ +%token ELSE /* else */ +%token END /* end */ +%token EVERY /* every */ +%token FAIL /* fail */ +%token GLOBAL /* global */ +%token IF /* if */ +%token INITIAL /* initial */ +%token INVOCABLE /* invocable */ +%token LINK /* link */ +%token LOCAL /* local */ +%token NEXT /* next */ +%token NOT /* not */ +%token OF /* of */ +%token PROCEDURE /* procedure */ +%token RECORD /* record */ +%token REPEAT /* repeat */ +%token RETURN /* return */ +%token STATIC /* static */ +%token SUSPEND /* suspend */ +%token THEN /* then */ +%token TO /* to */ +%token UNTIL /* until */ +%token WHILE /* while */ + +/* operators */ + +%token BANG /* ! */ +%token MOD /* % */ +%token AUGMOD /* %:= */ +%token AND /* & */ +%token AUGAND /* &:= */ +%token STAR /* * */ +%token AUGSTAR /* *:= */ +%token INTER /* ** */ +%token AUGINTER /* **:= */ +%token PLUS /* + */ +%token AUGPLUS /* +:= */ +%token UNION /* ++ */ +%token AUGUNION /* ++:= */ +%token MINUS /* - */ +%token AUGMINUS /* -:= */ +%token DIFF /* -- */ +%token AUGDIFF /* --:= */ +%token DOT /* . */ +%token SLASH /* / */ +%token AUGSLASH /* /:= */ +%token ASSIGN /* := */ +%token SWAP /* :=: */ +%token NMLT /* < */ +%token AUGNMLT /* <:= */ +%token REVASSIGN /* <- */ +%token REVSWAP /* <-> */ +%token SLT /* << */ +%token AUGSLT /* <<:= */ +%token SLE /* <<= */ +%token AUGSLE /* <<=:= */ +%token NMLE /* <= */ +%token AUGNMLE /* <=:= */ +%token NMEQ /* = */ +%token AUGNMEQ /* =:= */ +%token SEQ /* == */ +%token AUGSEQ /* ==:= */ +%token EQUIV /* === */ +%token AUGEQUIV /* ===:= */ +%token NMGT /* > */ +%token AUGNMGT /* >:= */ +%token NMGE /* >= */ +%token AUGNMGE /* >=:= */ +%token SGT /* >> */ +%token AUGSGT /* >>:= */ +%token SGE /* >>= */ +%token AUGSGE /* >>=:= */ +%token QMARK /* ? */ +%token AUGQMARK /* ?:= */ +%token AT /* @ */ +%token AUGAT /* @:= */ +%token BACKSLASH /* \ */ +%token CARET /* ^ */ +%token AUGCARET /* ^:= */ +%token BAR /* | */ +%token CONCAT /* || */ +%token AUGCONCAT /* ||:= */ +%token LCONCAT /* ||| */ +%token AUGLCONCAT /* |||:= */ +%token TILDE /* ~ */ +%token NMNE /* ~= */ +%token AUGNMNE /* ~=:= */ +%token SNE /* ~== */ +%token AUGSNE /* ~==:= */ +%token NEQUIV /* ~=== */ +%token AUGNEQUIV /* ~===:= */ +%token LPAREN /* ( */ +%token RPAREN /* ) */ +%token PCOLON /* +: */ +%token COMMA /* , */ +%token MCOLON /* -: */ +%token COLON /* : */ +%token SEMICOL /* ; */ +%token LBRACK /* [ */ +%token RBRACK /* ] */ +%token LBRACE /* { */ +%token RBRACE /* } */ diff --git a/src/common/yylex.h b/src/common/yylex.h new file mode 100644 index 0000000..9850417 --- /dev/null +++ b/src/common/yylex.h @@ -0,0 +1,624 @@ +/* + * yylex.h -- the lexical analyzer. + * + * This source file contains the lexical analyzer, yylex(), and its + * support routines. It is built by inclusion in ../icont/tlex.c and + * ../iconc/clex.c, with slight variations depending on whether "Iconc" + * is defined. + */ + +#if !defined(Iconc) + #include "../h/esctab.h" +#endif /* !Iconc */ + +/* + * Prototypes. + */ + +static int bufcmp (char *s); +static struct toktab *findres (void); +static struct toktab *getident (int ac,int *cc); +static struct toktab *getnum (int ac,int *cc); +static struct toktab *getstring (int ac,int *cc); +static int setfilenm (int c); +static int setlineno (void); + +#if !defined(Iconc) + static int ctlesc (void); + static int hexesc (void); + static int octesc (int ac); +#endif /* !Iconc */ + +#define isletter(s) (isupper(c) | islower(c)) +#define tonum(c) (isdigit(c) ? (c - '0') : ((c & 037) + 9)) + +struct node tok_loc = + {0, NULL, 0, 0}; /* "model" node containing location of current token */ + +struct str_buf lex_sbuf; /* string buffer for lexical analyzer */ + +/* + * yylex - find the next token in the input stream, and return its token + * type and value to the parser. + * + * Variables of interest: + * + * cc - character following last token. + * nlflag - set if a newline was between the last token and the current token + * lastend - set if the last token was an Ender. + * lastval - when a semicolon is inserted and returned, lastval gets the + * token value that would have been returned if the semicolon hadn't + * been inserted. + */ + +static struct toktab *lasttok = NULL; +static int lastend = 0; +static int eofflag = 0; +static int cc = '\n'; + +int yylex() + { + register struct toktab *t; + register int c; + int n; + int nlflag; + static nodeptr lastval; + static struct node semi_loc; + + if (lasttok != NULL) { + /* + * A semicolon was inserted and returned on the last call to yylex, + * instead of going to the input, return lasttok and set the + * appropriate variables. + */ + + yylval = lastval; + tok_loc = *lastval; + t = lasttok; + goto ret; + } + nlflag = 0; +loop: + c = cc; + /* + * Remember where a semicolon will go if we insert one. + */ + semi_loc.n_file = tok_loc.n_file; + semi_loc.n_line = in_line; + if (cc == '\n') + --semi_loc.n_line; + semi_loc.n_col = incol; + /* + * Skip whitespace and comments and process #line directives. + */ + while (c == Comment || isspace(c)) { + if (c == '\n') { + nlflag++; + c = NextChar; + if (c == Comment) { + /* + * Check for #line directive at start of line. + */ + if (('l' == (c = NextChar)) && + ('i' == (c = NextChar)) && + ('n' == (c = NextChar)) && + ('e' == (c = NextChar))) { + c = setlineno(); + while ((c == ' ') || (c == '\t')) + c = NextChar; + if (c != EOF && c != '\n') + c = setfilenm(c); + } + while (c != EOF && c != '\n') + c = NextChar; + } + } + else { + if (c == Comment) { + while (c != EOF && c != '\n') + c = NextChar; + } + else { + c = NextChar; + } + } + } + /* + * A token is the next thing in the input. Set token location to + * the current line and column. + */ + tok_loc.n_line = in_line; + tok_loc.n_col = incol; + + if (c == EOF) { + /* + * End of file has been reached. Set eofflag, return T_Eof, and + * set cc to EOF so that any subsequent scans also return T_Eof. + */ + if (eofflag++) { + eofflag = 0; + cc = '\n'; + yylval = NULL; + return 0; + } + cc = EOF; + t = T_Eof; + yylval = NULL; + goto ret; + } + + /* + * Look at current input character to determine what class of token + * is next and take the appropriate action. Note that the various + * token gathering routines write a value into cc. + */ + if (isalpha(c) || (c == '_')) { /* gather ident or reserved word */ + if ((t = getident(c, &cc)) == NULL) + goto loop; + } + else if (isdigit(c) || (c == '.')) { /* gather numeric literal or "." */ + if ((t = getnum(c, &cc)) == NULL) + goto loop; + } + else if (c == '"' || c == '\'') { /* gather string or cset literal */ + if ((t = getstring(c, &cc)) == NULL) + goto loop; + } + else { /* gather longest legal operator */ + if ((n = getopr(c, &cc)) == -1) + goto loop; + t = &(optab[n].tok); + yylval = OpNode(n); + } + if (nlflag && lastend && (t->t_flags & Beginner)) { + /* + * A newline was encountered between the current token and the last, + * the last token was an Ender, and the current token is a Beginner. + * Return a semicolon and save the current token in lastval. + */ + lastval = yylval; + lasttok = t; + tok_loc = semi_loc; + yylval = OpNode(semicol_loc); + return SEMICOL; + } +ret: + /* + * Clear lasttok, set lastend if the token being returned is an + * Ender, and return the token. + */ + lasttok = 0; + lastend = t->t_flags & Ender; + return (t->t_type); + } + +/* + * getident - gather an identifier beginning with ac. The character + * following identifier goes in cc. + */ + +static struct toktab *getident(ac, cc) +int ac; +int *cc; + { + register int c; + register struct toktab *t; + + c = ac; + /* + * Copy characters into string space until a non-alphanumeric character + * is found. + */ + do { + AppChar(lex_sbuf, c); + c = NextChar; + } while (isalnum(c) || (c == '_')); + *cc = c; + /* + * If the identifier is a reserved word, make a ResNode for it and return + * the token value. Otherwise, install it with putid, make an + * IdNode for it, and return. + */ + if ((t = findres()) != NULL) { + lex_sbuf.endimage = lex_sbuf.strtimage; + yylval = ResNode(t->t_type); + return t; + } + else { + yylval = IdNode(str_install(&lex_sbuf)); + return (struct toktab *)T_Ident; + } + } + +/* + * findres - if the string just copied into the string space by getident + * is a reserved word, return a pointer to its entry in the token table. + * Return NULL if the string isn't a reserved word. + */ + +static struct toktab *findres() + { + register struct toktab *t; + register char c; + + c = *lex_sbuf.strtimage; + if (!islower(c)) + return NULL; + /* + * Point t at first reserved word that starts with c (if any). + */ + if ((t = restab[c - 'a']) == NULL) + return NULL; + /* + * Search through reserved words, stopping when a match is found + * or when the current reserved word doesn't start with c. + */ + while (t->t_word[0] == c) { + if (bufcmp(t->t_word)) + return t; + t++; + } + return NULL; + } + +/* + * bufcmp - compare a null terminated string to what is in the string buffer. + */ +static int bufcmp(s) +char *s; + { + register char *s1; + s1 = lex_sbuf.strtimage; + while (s != '\0' && s1 < lex_sbuf.endimage && *s == *s1) { + ++s; + ++s1; + } + if (*s == '\0' && s1 == lex_sbuf.endimage) + return 1; + else + return 0; + } + +/* + * getnum - gather a numeric literal starting with ac and put the + * character following the literal into *cc. + * + * getnum also handles the "." operator, which is distinguished from + * a numeric literal by what follows it. + */ + +static struct toktab *getnum(ac, cc) +int ac; +int *cc; + { + register int c, r, state; + int realflag, n, dummy; + + c = ac; + if (c == '.') { + r = 0; + state = 7; + realflag = 1; + } + else { + r = tonum(c); + state = 0; + realflag = 0; + } + for (;;) { + AppChar(lex_sbuf, c); + c = NextChar; + switch (state) { + case 0: /* integer part */ + if (isdigit(c)) { r = r * 10 + tonum(c); continue; } + if (c == '.') { state = 1; realflag++; continue; } + if (c == 'e' || c == 'E') { state = 2; realflag++; continue; } + if (c == 'r' || c == 'R') { + state = 5; + if (r < 2 || r > 36) + tfatal("invalid radix for integer literal", (char *)NULL); + continue; + } + break; + case 1: /* fractional part */ + if (isdigit(c)) continue; + if (c == 'e' || c == 'E') { state = 2; continue; } + break; + case 2: /* optional exponent sign */ + if (c == '+' || c == '-') { state = 3; continue; } + case 3: /* first digit after e, e+, or e- */ + if (isdigit(c)) { state = 4; continue; } + tfatal("invalid real literal", (char *)NULL); + break; + case 4: /* remaining digits after e */ + if (isdigit(c)) continue; + break; + case 5: /* first digit after r */ + if ((isdigit(c) || isletter(c)) && tonum(c) < r) + { state = 6; continue; } + tfatal("invalid integer literal", (char *)NULL); + break; + case 6: /* remaining digits after r */ + if (isdigit(c) || isletter(c)) { + if (tonum(c) >= r) { /* illegal digit for radix r */ + tfatal("invalid digit in integer literal", (char *)NULL); + r = tonum('z'); /* prevent more messages */ + } + continue; + } + break; + case 7: /* token began with "." */ + if (isdigit(c)) { + state = 1; /* followed by digit is a real const */ + realflag = 1; + continue; + } + *cc = c; /* anything else is just a dot */ + lex_sbuf.endimage--; /* remove dot (undo AppChar) */ + n = getopr((int)'.', &dummy); + yylval = OpNode(n); + return &(optab[n].tok); + } + break; + } + *cc = c; + if (realflag) { + yylval = RealNode(str_install(&lex_sbuf)); + return T_Real; + } + yylval = IntNode(str_install(&lex_sbuf)); + return T_Int; + } + +/* + * getstring - gather a string literal starting with ac and place the + * character following the literal in *cc. + */ +static struct toktab *getstring(ac, cc) +int ac; +int *cc; + { + register int c, sc; + int sav_indx; + int len; + + sc = ac; + sav_indx = -1; + c = NextChar; + while (c != sc && c != '\n' && c != EOF) { + /* + * If a '_' is the last non-white space before a new-line, + * we must remember where it is. + */ + if (c == '_') + sav_indx = lex_sbuf.endimage - lex_sbuf.strtimage; + else if (!isspace(c)) + sav_indx = -1; + + if (c == Escape) { + c = NextChar; + if (c == EOF) + break; + +#if defined(Iconc) + AppChar(lex_sbuf, Escape); + if (c == '^') { + c = NextChar; + if (c == EOF) + break; + AppChar(lex_sbuf, '^'); + } +#else /* Iconc */ + if (isoctal(c)) + c = octesc(c); + else if (c == 'x') + c = hexesc(); + else if (c == '^') + c = ctlesc(); + else + c = esctab[c]; +#endif /* Iconc */ + + } + AppChar(lex_sbuf, c); + c = NextChar; + + /* + * If a '_' is the last non-white space before a new-line, the + * string continues at the first non-white space on the next line + * and everything from the '_' to the end of this line is ignored. + */ + if (c == '\n' && sav_indx >= 0) { + lex_sbuf.endimage = lex_sbuf.strtimage + sav_indx; + while ((c = NextChar) != EOF && isspace(c)) + ; + } + } + if (c == sc) + *cc = ' '; + else { + tfatal("unclosed quote", (char *)NULL); + *cc = c; + } + len = lex_sbuf.endimage - lex_sbuf.strtimage; + if (ac == '"') { /* a string literal */ + yylval = StrNode(str_install(&lex_sbuf), len); + return T_String; + } + else { /* a cset literal */ + yylval = CsetNode(str_install(&lex_sbuf), len); + return T_Cset; + } + } + +#if !defined(Iconc) + +/* + * ctlesc - translate a control escape -- backslash followed by + * caret and one character. + */ + +static int ctlesc() + { + register int c; + + c = NextChar; + if (c == EOF) + return EOF; + + return (c & 037); + } + +/* + * octesc - translate an octal escape -- backslash followed by + * one, two, or three octal digits. + */ + +static int octesc(ac) +int ac; + { + register int c, nc, i; + + c = 0; + nc = ac; + i = 1; + do { + c = (c << 3) | (nc - '0'); + nc = NextChar; + if (nc == EOF) + return EOF; + } while (isoctal(nc) && i++ < 3); + PushChar(nc); + + return (c & 0377); + } + +/* + * hexesc - translate a hexadecimal escape -- backslash-x + * followed by one or two hexadecimal digits. + */ + +static int hexesc() + { + register int c, nc, i; + + c = 0; + i = 0; + while (i++ < 2) { + nc = NextChar; + if (nc == EOF) + return EOF; + if (nc >= 'a' && nc <= 'f') + nc -= 'a' - 10; + else if (nc >= 'A' && nc <= 'F') + nc -= 'A' - 10; + else if (isdigit(nc)) + nc -= '0'; + else { + PushChar(nc); + break; + } + c = (c << 4) | nc; + } + + return c; + } + +#endif /* !Iconc */ + +/* + * setlineno - set line number from #line comment, return following char. + */ + +static int setlineno() + { + register int c; + + while ((c = NextChar) == ' ' || c == '\t') + ; + if (c < '0' || c > '9') { + tfatal("no line number in #line directive", ""); + while (c != EOF && c != '\n') + c = NextChar; + return c; + } + in_line = 0; + while (c >= '0' && c <= '9') { + in_line = in_line * 10 + (c - '0'); + c = NextChar; + } + return c; + } + +/* + * setfilenm - set file name from #line comment, return following char. + */ + +static int setfilenm(c) +register int c; + { + while (c == ' ' || c == '\t') + c = NextChar; + if (c != '"') { + tfatal("'\"' missing from file name in #line directive", ""); + while (c != EOF && c != '\n') + c = NextChar; + return c; + } + while ((c = NextChar) != '"' && c != EOF && c != '\n') + AppChar(lex_sbuf, c); + if (c == '"') { + tok_loc.n_file = str_install(&lex_sbuf); + return NextChar; + } + else { + tfatal("'\"' missing from file name in #line directive", ""); + return c; + } + } + +/* + * nextchar - return the next character in the input. + * + * Called from the lexical analyzer; interfaces it to the preprocessor. + */ + +int nextchar() + { + register int c; + + if ((c = peekc) != 0) { + peekc = 0; + return c; + } + c = ppch(); + switch (c) { + case EOF: + if (incol) { + c = '\n'; + in_line++; + incol = 0; + peekc = EOF; + break; + } + else { + in_line = 0; + incol = 0; + break; + } + case '\n': + in_line++; + incol = 0; + break; + case '\t': + incol = (incol | 7) + 1; + break; + case '\b': + if (incol) + incol--; + break; + default: + incol++; + } + return c; + } diff --git a/src/h/config.h b/src/h/config.h new file mode 100644 index 0000000..bc48ada --- /dev/null +++ b/src/h/config.h @@ -0,0 +1,309 @@ +/* + * Icon configuration. + */ + +/* + * System-specific definitions are in define.h, which is loaded first. + */ + +/* + * A number of symbols are defined here. + * Some enable or disable certain Icon features, for example: + * NoCoexpr disables co-expressions + * LoadFunc enables dynamic loading + * + * Other definitions may occur for different configurations. These include: + * DeBug debugging code + * MultiThread support for multiple programs under the interpreter + * + * Many definitions reflect remnants of past research projects. + * Changing them to values not used in standard configurations + * may result in an unbuildable or nonfunctioning system. + */ + +/* + * If COMPILER is not defined, code for the interpreter is compiled. + */ + +#ifndef COMPILER + #define COMPILER 0 +#endif + +/* + * The following definitions serve to cast common conditionals is + * a positive way, while allowing defaults for the cases that + * occur most frequently. That is, if co-expressions are not supported, + * NoCoexpr is defined in define.h, but if they are supported, no + * definition is needed in define.h; nonetheless subsequent conditionals + * can be cast as #ifdef Coexpr. + */ + +#ifndef NoCoexpr + #undef Coexpr + #define Coexpr +#endif /* NoCoexpr */ + +#ifdef NoCoexpr + #undef MultiThread + #undef EventMon + #undef Eve +#endif /* NoCoexpr */ + +#if COMPILER + #undef Eve + #undef MultiThread + #undef EventMon +#endif /* COMPILER */ + +#ifdef Eve + #undef EventMon + #undef MultiThread + #define EventMon + #define MultiThread +#endif /* Eve */ + +#ifndef NoLargeInts + #undef LargeInts + #define LargeInts +#endif /* NoLargeInts */ + +#ifdef EventMon + #undef MultiThread + #define MultiThread +#endif /* EventMon */ + +/* + * Graphics definitions. + */ +#ifdef Graphics + + #ifndef XWindows + #ifdef MSWIN + #undef WinGraphics + #define WinGraphics 1 + #else /* Graphics */ + #define XWindows 1 + #endif /* Graphics */ + #endif /* XWindows */ + + #ifndef NoXpmFormat + #ifdef XWindows + #undef HaveXpmFormat + #define HaveXpmFormat + #endif /* XWindows */ + #endif /* NoXpmFormat */ + + #undef LineCodes + #define LineCodes + + #undef Polling + #define Polling + + #ifndef ICONC_XLIB + #ifdef WinGraphics + #define ICONC_XLIB "-luser32 -lgdi32 -lcomdlg32 -lwinmm" + #else /* WinGraphics */ + #define ICONC_XLIB "-L/usr/X11R6/lib -lX11" + #endif /* WinGraphics */ + #endif /* ICONC_XLIB */ + +#endif /* Graphics */ + +/* + * Data sizes and alignment. + */ + +#define WordSize sizeof(word) + +#ifndef StackAlign + #define StackAlign 8 +#endif /* StackAlign */ + +/* + * Other defaults. + */ + +#ifdef DeBug + #undef DeBugTrans + #undef DeBugLinker + #undef DeBugIconx + #define DeBugTrans + #define DeBugLinker + #define DeBugIconx +#endif /* DeBug */ + +#ifndef MaxHdr + /* + * Maximum allowable BinaryHeader size. + * WARNING: changing this invalidates old BinaryHeader executables. + */ + #define MaxHdr 8192 +#endif /* MaxHdr */ + +#ifndef MaxPath + #define MaxPath 256 +#endif /* MaxPath */ + +#ifndef SourceSuffix + #define SourceSuffix ".icn" +#endif /* SourceSuffix */ + +/* + * Representations of directories. LocalDir is the "current working directory". + * SourceDir is where the source file is. + */ + +#define LocalDir "" +#define SourceDir (char *)NULL + +#ifndef TargetDir + #define TargetDir LocalDir +#endif /* TargetDir */ + +/* + * Features enabled by default. + */ +#ifndef NoPipes + #define Pipes +#endif /* Pipes */ + +#ifndef NoKeyboardFncs + #define KeyboardFncs +#endif /* KeyboardFncs */ + +#ifndef NoReadDirectory + #define ReadDirectory +#endif /* ReadDirectory */ + +#ifndef NoSysOpt + #define SysOpt +#endif /* SysOpt */ + +/* + * The following definitions assume ANSI C. + */ +#define Cat(x,y) x##y +#define Lit(x) #x +#define Bell '\a' + +/* + * Miscellaney. + */ + +#ifndef DiffPtrs + #define DiffPtrs(p1,p2) (word)((p1)-(p2)) +#endif /* DiffPtrs */ + +#ifndef AllocReg + #define AllocReg(n) malloc(n) +#endif /* AllocReg */ + +#ifndef RttSuffix + #define RttSuffix ".r" +#endif /* RttSuffix */ + +#ifndef DBSuffix + #define DBSuffix ".db" +#endif /* DBSuffix */ + +#ifndef PPInit + #define PPInit "" +#endif /* PPInit */ + +#ifndef PPDirectives + #define PPDirectives {"passthru", PpKeep}, +#endif /* PPDirectives */ + +#ifndef NoSrcColumnInfo + #define SrcColumnInfo +#endif /* NoSrcColumnInfo */ + +#ifndef ExecSuffix + #define ExecSuffix "" +#endif /* ExecSuffix */ + +#ifndef CSuffix + #define CSuffix ".c" +#endif /* CSuffix */ + +#ifndef HSuffix + #define HSuffix ".h" +#endif /* HSuffix */ + +#ifndef ObjSuffix + #define ObjSuffix ".o" +#endif /* ObjSuffix */ + +#ifndef LibSuffix + #define LibSuffix ".a" +#endif /* LibSuffix */ + +#ifndef CComp + #define CComp "cc" +#endif /* CComp */ + +#ifndef COpts + #define COpts "" +#endif /* COpts */ + +/* + * Note, size of the hash table is a power of 2: + */ +#define IHSize 128 +#define IHasher(x) (((unsigned int)(unsigned long)(x))&(IHSize-1)) + +#if COMPILER + + /* + * Code for the compiler. + */ + #undef MultiThread /* no way -- interpreter only */ + #undef EventMon /* presently not supported in the compiler */ + +#else /* COMPILER */ + + /* + * Code for the interpreter. + */ + #ifndef IcodeSuffix + #define IcodeSuffix "" + #endif /* IcodeSuffix */ + + #ifndef IcodeASuffix + #define IcodeASuffix "" + #endif /* IcodeASuffix */ + + #ifndef U1Suffix + #define U1Suffix ".u1" + #endif /* U1Suffix */ + + #ifndef U2Suffix + #define U2Suffix ".u2" + #endif /* U2Suffix */ + + #ifndef USuffix + #define USuffix ".u" + #endif /* USuffix */ + +#endif /* COMPILER */ + +/* + * Vsizeof is for use with variable-sized (i.e., indefinite) + * structures containing an array of descriptors declared of size 1 + * to avoid compiler warnings associated with 0-sized arrays. + */ + +#define Vsizeof(s) (sizeof(s) - sizeof(struct descrip)) + +/* + * Other sizeof macros: + * + * Wsizeof(x) -- Size of x in words. + * Vwsizeof(x) -- Size of x in words, minus the size of a descriptor. Used + * when structures have a potentially null list of descriptors + * at their end. + */ + +#define Wsizeof(x) ((sizeof(x) + sizeof(word) - 1) / sizeof(word)) +#define Vwsizeof(x) \ + ((sizeof(x) - sizeof(struct descrip) + sizeof(word) - 1) / sizeof(word)) diff --git a/src/h/cpuconf.h b/src/h/cpuconf.h new file mode 100644 index 0000000..228ce6b --- /dev/null +++ b/src/h/cpuconf.h @@ -0,0 +1,247 @@ +/* + * Configuration parameters that depend on computer architecture. + * Some depend on values defined in config.h, which is always + * included before this file. + */ + +#ifndef CStateSize + #define CStateSize 15 /* size of C state for co-expressions */ +#endif /* CStateSize */ + +/* + * The following definitions depend on the sizes of ints and pointers. + */ + +/* + * Most of the present implementations use 32-bit "words". Note that + * WordBits is the number of bits in an Icon integer, not necessarily + * the number of bits in an int (given by IntBits). In some systems + * an Icon integer is a long, not an int. + * + * MaxStrLen must not be so large as to overlap flags. + */ + +/* + * 64-bit words. + */ + +#if WordBits == 64 + + #ifndef MinLong + #define MinLong ((long int)0x8000000000000000) /* smallest long int */ + #endif + + #ifndef MaxLong + #define MaxLong ((long int)0x7fffffffffffffff) /* largest long integer */ + #endif + + #define MaxStrLen 017777777777L /* maximum string length */ + + #ifndef MaxNegInt + #define MaxNegInt "-9223372036854775808" + #endif + + #ifndef F_Nqual + #define F_Nqual 0x8000000000000000 /* set if NOT string qualifier*/ + #endif /* F_Nqual */ + + #ifndef F_Var + #define F_Var 0x4000000000000000 /* set if variable */ + #endif /* F_Var */ + + #ifndef F_Ptr + #define F_Ptr 0x1000000000000000 /* set if value field is ptr */ + #endif /* F_Ptr */ + + #ifndef F_Typecode + #define F_Typecode 0x2000000000000000 /* set if dword incls typecode*/ + #endif /* F_Typecode */ + +#endif /* WordBits == 64 */ + +/* + * 32-bit words. + */ + +#if WordBits == 32 + + #define MaxLong ((long int)017777777777L) /* largest long integer */ + #define MinLong ((long int)020000000000L) /* smallest long integer */ + + #define MaxNegInt "-2147483648" + + #define MaxStrLen 0777777777 /* maximum string length */ + + #define F_Nqual 0x80000000 /* set if NOT string qualifier */ + #define F_Var 0x40000000 /* set if variable */ + #define F_Ptr 0x10000000 /* set if value field is pointer */ + #define F_Typecode 0x20000000 /* set if dword includes type code */ + +#endif /* WordBits == 32 */ + +/* + * Values that depend on the number of bits in an int (not necessarily + * the same as the number of bits in a word). + */ + +#if IntBits == 64 + #define LogIntBits 6 /* log of IntBits */ + #define MaxUnsigned 01777777777777777777777L /* largest unsigned integer */ + #define MaxInt 0777777777777777777777L /* largest int */ + /* + * Cset initialization and access macros. + */ + #define fwd(w0, w1, w2, w3) \ + (((w0) & 0xffff) | (((unsigned)(w1) & 0xffff) << 16) | \ + (((unsigned)(w2) & 0xffff) << 32) | (((unsigned)(w3) & 0xffff) << 48)) + #define cset_display(w0,w1,w2,w3,w4,w5,w6,w7,w8,w9,wa,wb,wc,wd,we,wf) \ + {fwd(w0,w1,w2,w3),fwd(w4,w5,w6,w7),fwd(w8,w9,wa,wb),fwd(wc,wd,we,wf)} + #define Cset32(b,c) (*CsetPtr(b,c)>>(32*CsetOff((b)>>5))) /* 32b of cset */ +#endif /* IntBits == 64 */ + +#if IntBits == 32 + #define LogIntBits 5 /* log of IntBits */ + #define MaxUnsigned 037777777777 /* largest unsigned integer */ + #define MaxInt 017777777777 /* largest int */ + /* + * Cset initialization and access macros. + */ + #define twd(w0,w1) (((w0)&0xffff) | (((unsigned)w1)<<16)) + #define cset_display(w0,w1,w2,w3,w4,w5,w6,w7,w8,w9,wa,wb,wc,wd,we,wf) \ + {twd(w0,w1),twd(w2,w3),twd(w4,w5),twd(w6,w7), \ + twd(w8,w9),twd(wa,wb),twd(wc,wd),twd(we,wf)} + #define Cset32(b,c) (*CsetPtr(b,c)) /* 32 bits of cset */ +#endif /* IntBits == 32 */ + +#ifndef LogHuge + #define LogHuge 309 /* maximum base-10 exp+1 of real */ +#endif /* LogHuge */ + +#ifndef Big + #define Big 9007199254740992. /* larger than 2^53 lose precision */ +#endif /* Big */ + +#ifndef Precision + #define Precision 10 /* digits in string from real */ +#endif /* Precision */ + +/* + * Parameters that configure tables and sets: + * + * HSlots Initial number of hash buckets; must be a power of 2. + * LogHSlots Log to the base 2 of HSlots. + * + * HSegs Maximum number of hash bin segments; the maximum number of + * hash bins is HSlots * 2 ^ (HSegs - 1). + * + * If Hsegs is increased above 20, the arrays log2h[] and segsize[] + * in the runtime system will need modification. + * + * MaxHLoad Maximum loading factor; more hash bins are allocated when + * the average bin exceeds this many entries. + * + * MinHLoad Minimum loading factor; if a newly created table (e.g. via + * copy()) is more lightly loaded than this, bins are combined. + * + * Because splitting doubles the number of hash bins, and combining halves it, + * MaxHLoad should be at least twice MinHLoad. + */ + +#ifndef HSlots + #define HSlots 16 + #define LogHSlots 4 +#endif /* HSlots */ + +#if ((1 << LogHSlots) != HSlots) + #error HSlots and LogHSlots are inconsistent +#endif /* HSlots / LogHSlots consistency */ + +#ifndef HSegs + #define HSegs 20 +#endif /* HSegs */ + +#ifndef MinHLoad + #define MinHLoad 1 +#endif /* MinHLoad */ + +#ifndef MaxHLoad + #define MaxHLoad 5 +#endif /* MaxHLoad */ + +/* + * The number of bits in each base-B digit; the type DIGIT (unsigned int) + * in rt.h must be large enough to hold this many bits. + * It must be at least 2 and at most WordBits / 2. + */ +#define NB (WordBits / 2) + +/* + * The number of decimal digits at which the image lf a large integer + * goes from exact to approximate (to avoid possible long delays in + * conversion from large integer to string because of its quadratic + * complexity). + */ +#define MaxDigits 30 + +/* + * Memory sizing. + */ +#ifndef AlcMax + #define AlcMax 25 +#endif /* AlcMax */ + +/* + * Maximum sized block that can be allocated (via malloc() or such). + */ +#ifndef MaxBlock + #define MaxBlock MaxUnsigned +#endif /* MaxBlock */ + +/* + * What follows is default memory sizing. Implementations with special + * requirements may specify these values in define.h. + */ + +#ifndef MaxStrSpace + #define MaxStrSpace 500000 /* size of the string space in bytes */ +#endif /* MaxStrSpace */ + +#ifndef MaxAbrSize + #define MaxAbrSize 500000 /* size of the block region in bytes */ +#endif /* MaxAbrSize */ + +#ifndef MinAbrSize + #define MinAbrSize 5000 /* minimum block region size */ +#endif /* MinAbrSize */ + +#ifndef MStackSize + #ifdef MultiThread + #define MStackSize 20000 /* size of the main stack in words */ + #else /* MultiThread */ + #define MStackSize 10000 /* size of the main stack in words */ + #endif /* MultiThread */ +#endif /* MStackSize */ + +#ifndef StackSize + #define StackSize 2000 /* words in co-expression stack */ +#endif /* StackSize */ + +#ifndef QualLstSize + #define QualLstSize 5000 /* size of qualifier pointer region */ +#endif /* QualLstSize */ + +#ifndef ActStkBlkEnts + #ifdef Coexpr + #define ActStkBlkEnts 25 /* number of entries in an astkblk */ + #else /* Coexpr */ + #define ActStkBlkEnts 1 /* number of entries in an astkblk */ + #endif /* Coexpr */ +#endif /* ActStkBlkEnts */ + +#ifndef RegionCushion + #define RegionCushion 10 /* % memory cushion to avoid thrashing*/ +#endif /* RegionCushion */ + +#ifndef RegionGrowth + #define RegionGrowth 200 /* % region growth when full */ +#endif /* RegionGrowth */ diff --git a/src/h/cstructs.h b/src/h/cstructs.h new file mode 100644 index 0000000..4301805 --- /dev/null +++ b/src/h/cstructs.h @@ -0,0 +1,317 @@ +/* + * cstructs.h - structures and accompanying manifest constants for functions + * in the common subdirectory. + */ + +/* + * fileparts holds a file name broken down into parts. + */ +struct fileparts { /* struct of file name parts */ + char *dir; /* directory */ + char *name; /* name */ + char *ext; /* extension */ + }; + +/* + * xval - holds references to literal constants + */ +union xval { + long ival; /* integer */ + double rval; /* real */ + word sval; /* offset into string space of string */ + }; + +/* + * str_buf references a string buffer. Strings are built a character + * at a time. When a buffer "fragment" is filled, another is allocated + * and the the current string copied to it. + */ +struct str_buf_frag { + struct str_buf_frag *next; /* next buffer fragment */ + char s[1]; /* variable size buffer, really > 1 */ + }; + +struct str_buf { + unsigned int size; /* total size of current buffer */ + char *strtimage; /* start of string currently being built */ + char *endimage; /* next free character in buffer */ + char *end; /* end of current buffer */ + struct str_buf_frag *frag_lst; /* list of buffer fragments */ + struct str_buf *next; /* buffers can be put on free list */ + }; + +#define AppChar(sbuf, c) do {\ + if ((sbuf).endimage >= (sbuf).end)\ + new_sbuf(&(sbuf));\ + *((sbuf).endimage)++ = (c);\ + } while (0) + +/* + * implement contains information about the implementation of an operation. + */ +#define NoRsltSeq -1L /* no result sequence: {} */ +#define UnbndSeq -2L /* unbounded result sequence: {*} */ + +#define DoesRet 01 /* operation (or "body" function) returns */ +#define DoesFail 02 /* operation (or "body" function) fails */ +#define DoesSusp 04 /* operation (or "body" function) suspends */ +#define DoesEFail 010 /* fails through error conversion */ +#define DoesFThru 020 /* only "body" functions can "fall through" */ + +struct implement { + struct implement *blink; /* link for bucket chain in hash tables */ + char oper_typ; /* 'K'=keyword, 'F'=function, 'O'=operator */ + char prefix[2]; /* prefix to make start of name unique */ + char *name; /* function/operator/keyword name */ + char *op; /* operator symbol (operators only) */ + int nargs; /* number of arguments operation requires */ + int *arg_flgs; /* array of arg flags: deref/underef, var len*/ + long min_result; /* minimum result sequence length */ + long max_result; /* maiximum result sequence length */ + int resume; /* flag - resumption after last result */ + int ret_flag; /* DoesRet, DoesFail, DoesSusp */ + int use_rslt; /* flag - explicitly uses result location */ + char *comment; /* description of operation */ + int ntnds; /* size of tnds array */ + struct tend_var *tnds; /* pointer to array of info about tended vars */ + int nvars; /* size of vars array */ + struct ord_var *vars; /* pointer to array of info about ordinary vars */ + struct il_code *in_line; /* inline version of the operation */ + int iconc_flgs; /* flags for internal use by the compiler */ + }; + +/* + * These codes are shared between the data base and rtt. They are defined + * here, though not all are used by the data base. + */ +#define TndDesc 1 /* a tended descriptor */ +#define TndStr 2 /* a tended character pointer */ +#define TndBlk 3 /* a tended block pointer */ +#define OtherDcl 4 /* a declaration that is not special */ +#define IsTypedef 5 /* a typedef */ +#define VArgLen 6 /* identifier for length of variable parm list */ +#define RsltLoc 7 /* the special result location of an operation */ +#define Label 8 /* label */ +#define RtParm 16 /* undereferenced parameter of run-time routine */ +#define DrfPrm 32 /* dereferenced parameter of run-time routine */ +#define VarPrm 64 /* variable part of parm list (with RtParm or DrfPrm) */ +#define PrmMark 128 /* flag - used while recognizing params of body fnc */ +#define ByRef 256 /* flag - parameter to body function passed by reference */ + +/* + * Flags to indicate what types are returned from the function implementing + * a body. These are unsed in determining the calling conventions + * of the function. + */ +#define RetInt 1 /* body/function returns a C_integer */ +#define RetDbl 2 /* body/function returns a C_double */ +#define RetOther 4 /* body (not function itself) returns something else */ +#define RetNoVal 8 /* function returns no value */ +#define RetSig 16 /* function returns a signal */ + +/* + * tend_var contains information about a tended variable in the "declare {...}" + * action of an operation. + */ +struct tend_var { + int var_type; /* TndDesc, TndStr, or TndBlk */ + struct il_c *init; /* initial value from declaration */ + char *blk_name; /* TndBlk: struct name of block */ + }; + +/* + * ord_var contains information about an ordinary variable in the + * "declare {...}" action of an operation. + */ +struct ord_var { + char *name; /* name of variable */ + struct il_c *dcl; /* declaration of variable (includes name) */ + }; + +/* + * il_code has information about an action in an operation. + */ +#define IL_If1 1 +#define IL_If2 2 +#define IL_Tcase1 3 +#define IL_Tcase2 4 +#define IL_Lcase 5 +#define IL_Err1 6 +#define IL_Err2 7 +#define IL_Lst 8 +#define IL_Const 9 +#define IL_Bang 10 +#define IL_And 11 +#define IL_Cnv1 12 +#define IL_Cnv2 13 +#define IL_Def1 14 +#define IL_Def2 15 +#define IL_Is 16 +#define IL_Var 17 +#define IL_Subscr 18 +#define IL_Block 19 +#define IL_Call 20 +#define IL_Abstr 21 +#define IL_VarTyp 22 +#define IL_Store 23 +#define IL_Compnt 24 +#define IL_TpAsgn 25 +#define IL_Union 26 +#define IL_Inter 27 +#define IL_New 28 +#define IL_IcnTyp 29 +#define IL_Acase 30 + +#define CM_Fields -1 + +union il_fld { + struct il_code *fld; + struct il_c *c_cd; + int *vect; + char *s; + word n; + }; + +struct il_code { + int il_type; + union il_fld u[1]; /* actual number of fields varies with type */ + }; + +/* + * The following manifest constants are used to describe types, conversions, + * and returned values. Non-negative numbers are reserved for types described + * in the type specification system. + */ +#define TypAny -1 +#define TypEmpty -2 +#define TypVar -3 +#define TypCInt -4 +#define TypCDbl -5 +#define TypCStr -6 +#define TypEInt -7 +#define TypECInt -8 +#define TypTStr -9 +#define TypTCset -10 +#define RetDesc -11 +#define RetNVar -12 +#define RetSVar -13 +#define RetNone -14 + +/* + * il_c describes a piece of C code. + */ +#define ILC_Ref 1 /* nonmodifying reference to var. in sym. tab. */ +#define ILC_Mod 2 /* modifying reference to var. in sym. tab */ +#define ILC_Tend 3 /* tended var. local to inline block */ +#define ILC_SBuf 4 /* string buffer */ +#define ILC_CBuf 5 /* cset buffer */ +#define ILC_Ret 6 /* return statement */ +#define ILC_Susp 7 /* suspend statement */ +#define ILC_Fail 8 /* fail statement */ +#define ILC_Goto 9 /* goto */ +#define ILC_CGto 10 /* conditional goto */ +#define ILC_Lbl 11 /* label */ +#define ILC_LBrc 12 /* '{' */ +#define ILC_RBrc 13 /* '}' */ +#define ILC_Str 14 /* arbitrary string of code */ +#define ILC_EFail 15 /* errorfail statement */ + +#define RsltIndx -1 /* symbol table index for "result" */ + +struct il_c { + int il_c_type; + struct il_c *code[3]; + word n; + char *s; + struct il_c *next; + }; + +/* + * The parameter value of a run-time operation may be in one of several + * different locations depending on what conversions have been done to it. + * These codes are shared by rtt and iconc. + */ +#define PrmTend 1 /* in tended location */ +#define PrmCStr 3 /* converted to C string: tended location */ +#define PrmInt 4 /* converted to C int: non-tended location */ +#define PrmDbl 8 /* converted to C double: non-tended location */ + +/* + * Kind of RLT return statement supported. + */ +#define TRetNone 0 /* does not support an RTL return statement */ +#define TRetBlkP 1 /* block pointer */ +#define TRetDescP 2 /* descriptor pointer */ +#define TRetCharP 3 /* character pointer */ +#define TRetCInt 4 /* C integer */ +#define TRetSpcl 5 /* RLT return statement has special form & semenatics */ + +/* + * Codes for dereferencing needs. + */ +#define DrfNone 0 /* not a variable type */ +#define DrfGlbl 1 /* treat as a global variable */ +#define DrfCnst 2 /* type of values in variable doesn't change */ +#define DrfSpcl 3 /* special dereferencing: trapped variable */ + +/* + * Information about an Icon type. + */ +struct icon_type { + char *id; /* name of type */ + int support_new; /* supports RTL "new" construct */ + int deref; /* dereferencing needs */ + int rtl_ret; /* kind of RTL return supported if any */ + char *typ; /* for variable: initial type */ + int num_comps; /* for aggregate: number of type components */ + int compnts; /* for aggregate: index of first component */ + char *abrv; /* abreviation used for type tracing */ + char *cap_id; /* name of type with first character capitalized */ + }; + +/* + * Information about a component of an aggregate type. + */ +struct typ_compnt { + char *id; /* name of component */ + int n; /* position of component within type aggragate */ + int var; /* flag: this component is an Icon-level variable */ + int aggregate; /* index of type that owns the component */ + char *abrv; /* abreviation used for type tracing */ + }; + +extern int num_typs; /* number of types in table */ +extern struct icon_type icontypes[]; /* table of icon types */ + +/* + * Type inference needs to know where most of the standard types + * reside. Some have special uses outside operations written in + * RTL code, such as the null type for initializing variables, and + * others have special semantics, such as trapped variables. + */ +extern int str_typ; /* index of string type */ +extern int int_typ; /* index of integer type */ +extern int rec_typ; /* index of record type */ +extern int proc_typ; /* index of procedure type */ +extern int coexp_typ; /* index of co-expression type */ +extern int stv_typ; /* index of sub-string trapped var type */ +extern int ttv_typ; /* index of table-elem trapped var type */ +extern int null_typ; /* index of null type */ +extern int cset_typ; /* index of cset type */ +extern int real_typ; /* index of real type */ +extern int list_typ; /* index of list type */ +extern int tbl_typ; /* index of table type */ + +extern int num_cmpnts; /* number of aggregate components */ +extern struct typ_compnt typecompnt[]; /* table of aggregate components */ +extern int str_var; /* index of trapped string variable */ +extern int trpd_tbl; /* index of trapped table */ +extern int lst_elem; /* index of list element */ +extern int tbl_val; /* index of table element value */ +extern int tbl_dflt; /* index of table default */ + +/* + * minimum number of unsigned ints needed to hold the bits of a cset - only + * used in translators, not in the run-time system. + */ +#define BVectSize 16 diff --git a/src/h/esctab.h b/src/h/esctab.h new file mode 100644 index 0000000..0098852 --- /dev/null +++ b/src/h/esctab.h @@ -0,0 +1,38 @@ +/* + * esctab.h - table for translating single-char escapes in string literals. + */ + +static unsigned char esctab[] = { + 000, 001, 002, 003, 004, 005, 006, 007, /* NUL-BEL */ + 010, 011, 012, 013, 014, 015, 016, 017, /* BS -SI */ + 020, 021, 022, 023, 024, 025, 026, 027, /* DLE-ETB */ + 030, 031, 032, 033, 034, 035, 036, 037, /* CAN-US */ + ' ', '!', '"', '#', '$', '%', '&', '\'', /* !"#$%&' */ + '(', ')', '*', '+', ',', '-', '.', '/', /* ()*+,-./ */ + 000, 001, 002, 003, 004, 005, 006, 007, /* 01234567 */ + 010, 011, ':', ';', '<', '=', '>', '?', /* 89:;<=>? */ + '@', 'A', '\b', 'C', 0177, 033, 014, 'G', /* @ABCDEFG */ + 'H', 'I', 'J', 'K', '\n', 'M', '\n', 'O', /* HIJKLMNO */ + 'P', 'Q', '\r', 'S', '\t', 'U', 013, 'W', /* PQRSTUVW */ + 'X', 'Y', 'Z', '[', '\\', ']', '^', '_', /* XYZ[\]^_ */ + '`', 'a', '\b', 'c', 0177, 033, 014, 'g', /* `abcdefg */ + 'h', 'i', 'j', 'k', '\n', 'm', '\n', 'o', /* hijklmno */ + 'p', 'q', '\r', 's', '\t', 'u', 013, 'w', /* pqrstuvw */ + 'x', 'y', 'z', '{', '|', '}', '~', 0177, /* xyz{|}~ */ + 0200, 0201, 0202, 0203, 0204, 0205, 0206, 0207, + 0210, 0211, 0212, 0213, 0214, 0215, 0216, 0217, + 0220, 0221, 0222, 0223, 0224, 0225, 0226, 0227, + 0230, 0231, 0232, 0233, 0234, 0235, 0236, 0237, + 0240, 0241, 0242, 0243, 0244, 0245, 0246, 0247, + 0250, 0251, 0252, 0253, 0254, 0255, 0256, 0257, + 0260, 0261, 0262, 0263, 0264, 0265, 0266, 0267, + 0270, 0271, 0272, 0273, 0274, 0275, 0276, 0277, + 0300, 0301, 0302, 0303, 0304, 0305, 0306, 0307, + 0310, 0311, 0312, 0313, 0314, 0315, 0316, 0317, + 0320, 0321, 0322, 0323, 0324, 0325, 0326, 0327, + 0330, 0331, 0332, 0333, 0334, 0335, 0336, 0337, + 0340, 0341, 0342, 0343, 0344, 0345, 0346, 0347, + 0350, 0351, 0352, 0353, 0354, 0355, 0356, 0357, + 0360, 0361, 0362, 0363, 0364, 0365, 0366, 0367, + 0370, 0371, 0372, 0373, 0374, 0375, 0376, 0377, + }; diff --git a/src/h/fdefs.h b/src/h/fdefs.h new file mode 100644 index 0000000..8f35509 --- /dev/null +++ b/src/h/fdefs.h @@ -0,0 +1,232 @@ +/* + * Definitions of functions. + */ + +FncDef(abs,1) +FncDef(acos,1) +FncDef(any,4) +FncDef(args,1) +FncDef(asin,1) +FncDef(atan,2) +FncDef(bal,6) +FncDef(center,3) +FncDef(char,1) +FncDef(chdir,1) +FncDef(close,1) +FncDef(collect,2) +FncDef(copy,1) +FncDef(cos,1) +FncDef(cset,1) +FncDef(delay,1) +FncDef(delete,2) +FncDefV(detab) +FncDef(dtor,1) +FncDefV(entab) +FncDef(errorclear,0) +FncDef(exit,1) +FncDef(exp,2) +FncDef(find,4) +FncDef(flush,1) +FncDef(function,0) +FncDef(get,2) +FncDef(getenv,1) +FncDef(iand,2) +FncDef(icom,1) +FncDef(image,1) +FncDef(insert,3) +FncDef(integer,1) +FncDef(ior,2) +FncDef(ishift,2) +FncDef(ixor,2) +FncDef(key,2) +FncDef(left,3) +FncDef(list,2) +FncDef(log,1) +FncDef(many,4) +FncDef(map,3) +FncDef(match,4) +FncDef(member,1) +FncDef(move,1) +FncDef(numeric,1) +FncDef(ord,1) +FncDef(pop,1) +FncDef(pos,1) +FncDef(pull,1) +FncDefV(push) +FncDefV(put) +FncDef(read,2) +FncDef(reads,2) +FncDef(real,1) +FncDef(remove,2) +FncDef(rename,1) +FncDef(repl,2) +FncDef(reverse,1) +FncDef(right,3) +FncDef(rtod,1) +FncDefV(runerr) +FncDef(seek,2) +FncDef(seq,2) +FncDef(serial,1) +FncDef(set,1) +FncDef(sin,1) +FncDef(sort,2) +FncDef(sortf,2) +FncDef(sqrt,1) +FncDefV(stop) +FncDef(string,1) +FncDef(system,1) +FncDef(tab,1) +FncDef(table,1) +FncDef(tan,1) +FncDef(trim,2) +FncDef(type,1) +FncDef(upto,4) +FncDef(where,1) +FncDefV(write) +FncDefV(writes) + +#ifdef Graphics + FncDefV(open) +#else /* Graphics */ + FncDef(open,3) +#endif /* Graphics */ + +#ifdef MultiThread + FncDef(display,3) + FncDef(name,2) + FncDef(proc,3) + FncDef(variable,3) +#else /* MultiThread */ + FncDef(display,2) + FncDef(name,1) + FncDef(proc,2) + FncDef(variable,1) +#endif /* MultiThread */ + +/* + * Dynamic loading. + */ +#ifdef LoadFunc + FncDef(loadfunc,2) +#endif /* LoadFunc */ + +/* + * External functions. + */ +#ifdef ExternalFunctions + FncDefV(callout) +#endif /* ExternalFunctions */ + +/* + * File attribute function. + */ +#ifdef FAttrib + FncDefV(fattrib) +#endif /* FAttrib */ + +/* + * Keyboard Functions + */ +#ifdef KeyboardFncs + FncDef(getch,0) + FncDef(getche,0) + FncDef(kbhit,0) +#endif /* KeyboardFncs */ + +/* + * Event processing functions. + */ +#ifdef EventMon + FncDef(EvGet,2) + FncDef(event,3) + FncDef(eventmask,2) + FncDef(opmask,2) +#endif /* EventMon */ + +/* + * Graphics functions. + */ +#ifdef Graphics + FncDef(Active,0) + FncDefV(Alert) + FncDefV(Bg) + FncDefV(Clip) + FncDefV(Clone) + FncDefV(Color) + FncDefV(ColorValue) + FncDefV(CopyArea) + FncDefV(Couple) + FncDefV(DrawArc) + FncDefV(DrawCircle) + FncDefV(DrawCurve) + FncDefV(DrawImage) + FncDefV(DrawLine) + FncDefV(DrawPoint) + FncDefV(DrawPolygon) + FncDefV(DrawRectangle) + FncDefV(DrawSegment) + FncDefV(DrawString) + FncDefV(EraseArea) + FncDefV(Event) + FncDefV(Fg) + FncDefV(FillArc) + FncDefV(FillCircle) + FncDefV(FillPolygon) + FncDefV(FillRectangle) + FncDefV(Font) + FncDefV(FreeColor) + FncDefV(GotoRC) + FncDefV(GotoXY) + FncDefV(Lower) + FncDefV(NewColor) + FncDefV(PaletteChars) + FncDefV(PaletteColor) + FncDefV(PaletteKey) + FncDefV(Pattern) + FncDefV(Pending) + FncDefV(Pixel) + FncDef(QueryPointer,1) + FncDefV(Raise) + FncDefV(ReadImage) + FncDefV(TextWidth) + FncDef(Uncouple,1) + FncDefV(WAttrib) + FncDefV(WDefault) + FncDefV(WFlush) + FncDef(WSync,1) + FncDefV(WriteImage) + /* + * Native function extensions for Windows + */ + #ifdef WinExtns + FncDefV(WinPlayMedia) + FncDefV(WinEditRegion) + FncDefV(WinButton) + FncDefV(WinScrollBar) + FncDefV(WinMenuBar) + FncDefV(WinColorDialog) + FncDefV(WinFontDialog) + FncDefV(WinOpenDialog) + FncDefV(WinSaveDialog) + FncDefV(WinSelectDialog) + #endif /* WinExtns */ +#endif /* Graphics */ + +#ifdef MultiThread + /* + * These functions are part of the MultiThread extensions. + */ + FncDef(cofail,1) + FncDef(globalnames,1) + FncDef(fieldnames,1) + FncDef(localnames,2) + FncDef(staticnames,2) + FncDef(paramnames,2) + FncDef(structure,1) + /* + * These functions are inherent to MultiThread and multiple Icon programs + */ + FncDefV(load) + FncDef(parent,1) + FncDef(keyword,2) +#endif /* MultiThread */ diff --git a/src/h/features.h b/src/h/features.h new file mode 100644 index 0000000..047b4df --- /dev/null +++ b/src/h/features.h @@ -0,0 +1,77 @@ +/* + * features.h -- predefined symbols and &features + * + * This file consists entirely of a sequence of conditionalized calls + * to the Feature() macro. The macro is not defined here, but is + * defined to different things by the the code that includes it. + * + * For the macro call Feature(guard,symname,kwval) + * the parameters are: + * guard for the compiler's runtime system, an expression that must + * evaluate as true for the feature to be included in &features + * symname predefined name in the preprocessor; "" if none + * kwval value produced by the &features keyword; 0 if none + * + * The translator and compiler modify this list of predefined symbols + * through calls to ppdef(). + */ + + Feature(1, "_V9", 0) /* Version 9 (unconditional) */ + +#if MSWIN + Feature(1, "_MS_WINDOWS", "MS Windows") +#endif /* MSWIN */ + +#if CYGWIN + Feature(1, "_CYGWIN", "Cygwin") +#endif /* CYGWIN */ + +#if UNIX + Feature(1, "_UNIX", "UNIX") +#endif /* UNIX */ + + Feature(1, "_ASCII", "ASCII") + +#ifdef Coexpr + Feature(1, "_CO_EXPRESSIONS", "co-expressions") +#endif /* Coexpr */ + +#ifdef LoadFunc + Feature(1, "_DYNAMIC_LOADING", "dynamic loading") +#endif /* LoadFunc */ + + Feature(1, "", "environment variables") + +#ifdef EventMon + Feature(1, "_EVENT_MONITOR", "event monitoring") +#endif /* EventMon */ + +#ifdef ExternalFunctions + Feature(1, "_EXTERNAL_FUNCTIONS", "external functions") +#endif /* ExternalFunctions */ + +#ifdef KeyboardFncs + Feature(1, "_KEYBOARD_FUNCTIONS", "keyboard functions") +#endif /* KeyboardFncs */ + +#ifdef LargeInts + Feature(largeints, "_LARGE_INTEGERS", "large integers") +#endif /* LargeInts */ + +#ifdef MultiThread + Feature(1, "_MULTITASKING", "multiple programs") +#endif /* MultiThread */ + +#ifdef Pipes + Feature(1, "_PIPES", "pipes") +#endif /* Pipes */ + + Feature(1, "_SYSTEM_FUNCTION", "system function") + +#ifdef Graphics + Feature(1, "_GRAPHICS", "graphics") +#endif /* Graphics */ + +#ifdef XWindows + Feature(1, "_X_WINDOW_SYSTEM", "X Windows") +#endif /* XWindows */ diff --git a/src/h/grammar.h b/src/h/grammar.h new file mode 100644 index 0000000..3a49b9d --- /dev/null +++ b/src/h/grammar.h @@ -0,0 +1,273 @@ +/* + * grammar.h -- Yacc grammar for Icon + * + * This file is combined with other files to make the Yacc input for + * building icont, iconc, and variant translators. + * + * Any modifications to this grammar will require corresponding changes to + * parserr.h, icont/tgrammar.c, iconc/cgrammar.c, and vtran/vtfiles/ident.c. + */ + +program : decls EOFX {Progend($1,$2);} ; + +decls : ; + | decls decl ; + +decl : record {Recdcl($1);} ; + | proc {Procdcl($1);} ; + | global {Globdcl($1);} ; + | link {Linkdcl($1);} ; + | invocable {Invocdcl($1);} ; + +invocable : INVOCABLE invoclist {Invocable($1, $2);} ; + +invoclist : invocop; + | invoclist COMMA invocop {Invoclist($1,$2,$3);} ; + +invocop : IDENT {Invocop1($1);} ; + | STRINGLIT {Invocop2($1);} ; + | STRINGLIT COLON INTLIT {Invocop3($1,$2,$3);} ; + +link : LINK lnklist {Link($1, $2);} ; + +lnklist : lnkfile ; + | lnklist COMMA lnkfile {Lnklist($1,$2,$3);} ; + +lnkfile : IDENT {Lnkfile1($1);} ; + | STRINGLIT {Lnkfile2($1);} ; + +global : GLOBAL {Global0($1);} idlist {Global1($1, $2, $3);} ; + +record : RECORD IDENT {Record1($1,$2);} LPAREN fldlist RPAREN { + Record2($1,$2,$3,$4,$5,$6); + } ; + +fldlist : {Arglist1();} ; + | idlist {Arglist2($1);} ; + +proc : prochead SEMICOL locals initial procbody END { + Proc1($1,$2,$3,$4,$5,$6); + } ; + +prochead: PROCEDURE IDENT {Prochead1($1,$2);} LPAREN arglist RPAREN { + Prochead2($1,$2,$3,$4,$5,$6); + } ; + +arglist : {Arglist1();} ; + | idlist {Arglist2($1);} ; + | idlist LBRACK RBRACK {Arglist3($1,$2,$3);} ; + + +idlist : IDENT { + Ident($1); + } ; + | idlist COMMA IDENT { + Idlist($1,$2,$3); + } ; + +locals : {Locals1();} ; + | locals retention idlist SEMICOL {Locals2($1,$2,$3,$4);} ; + +retention: LOCAL {Local($1);} ; + | STATIC {Static($1);} ; + +initial : {Initial1();} ; + | INITIAL expr SEMICOL {Initial2($1,$2,$3);} ; + +procbody: {Procbody1();} ; + | nexpr SEMICOL procbody {Procbody2($1,$2,$3);} ; + +nexpr : {Nexpr();} ; + | expr ; + +expr : expr1a ; + | expr AND expr1a {Bamper($1,$2,$3);} ; + +expr1a : expr1 ; + | expr1a QMARK expr1 {Bques($1,$2,$3);} ; + +expr1 : expr2 ; + | expr2 SWAP expr1 {Bswap($1,$2,$3);} ; + | expr2 ASSIGN expr1 {Bassgn($1,$2,$3);} ; + | expr2 REVSWAP expr1 {Brswap($1,$2,$3);} ; + | expr2 REVASSIGN expr1 {Brassgn($1,$2,$3);} ; + | expr2 AUGCONCAT expr1 {Baugcat($1,$2,$3);} ; + | expr2 AUGLCONCAT expr1 {Bauglcat($1,$2,$3);} ; + | expr2 AUGDIFF expr1 {Bdiffa($1,$2,$3);} ; + | expr2 AUGUNION expr1 {Buniona($1,$2,$3);} ; + | expr2 AUGPLUS expr1 {Bplusa($1,$2,$3);} ; + | expr2 AUGMINUS expr1 {Bminusa($1,$2,$3);} ; + | expr2 AUGSTAR expr1 {Bstara($1,$2,$3);} ; + | expr2 AUGINTER expr1 {Bintera($1,$2,$3);} ; + | expr2 AUGSLASH expr1 {Bslasha($1,$2,$3);} ; + | expr2 AUGMOD expr1 {Bmoda($1,$2,$3);} ; + | expr2 AUGCARET expr1 {Bcareta($1,$2,$3);} ; + | expr2 AUGNMEQ expr1 {Baugeq($1,$2,$3);} ; + | expr2 AUGEQUIV expr1 {Baugeqv($1,$2,$3);} ; + | expr2 AUGNMGE expr1 {Baugge($1,$2,$3);} ; + | expr2 AUGNMGT expr1 {Bauggt($1,$2,$3);} ; + | expr2 AUGNMLE expr1 {Baugle($1,$2,$3);} ; + | expr2 AUGNMLT expr1 {Bauglt($1,$2,$3);} ; + | expr2 AUGNMNE expr1 {Baugne($1,$2,$3);} ; + | expr2 AUGNEQUIV expr1 {Baugneqv($1,$2,$3);} ; + | expr2 AUGSEQ expr1 {Baugseq($1,$2,$3);} ; + | expr2 AUGSGE expr1 {Baugsge($1,$2,$3);} ; + | expr2 AUGSGT expr1 {Baugsgt($1,$2,$3);} ; + | expr2 AUGSLE expr1 {Baugsle($1,$2,$3);} ; + | expr2 AUGSLT expr1 {Baugslt($1,$2,$3);} ; + | expr2 AUGSNE expr1 {Baugsne($1,$2,$3);} ; + | expr2 AUGQMARK expr1 {Baugques($1,$2,$3);} ; + | expr2 AUGAND expr1 {Baugamper($1,$2,$3);} ; + | expr2 AUGAT expr1 {Baugact($1,$2,$3);} ; + +expr2 : expr3 ; + | expr2 TO expr3 {To0($1,$2,$3);} ; + | expr2 TO expr3 BY expr3 {To1($1,$2,$3,$4,$5);} ; + +expr3 : expr4 ; + | expr4 BAR expr3 {Alt($1,$2,$3);} ; + +expr4 : expr5 ; + | expr4 SEQ expr5 {Bseq($1,$2,$3);} ; + | expr4 SGE expr5 {Bsge($1,$2,$3);} ; + | expr4 SGT expr5 {Bsgt($1,$2,$3);} ; + | expr4 SLE expr5 {Bsle($1,$2,$3);} ; + | expr4 SLT expr5 {Bslt($1,$2,$3);} ; + | expr4 SNE expr5 {Bsne($1,$2,$3);} ; + | expr4 NMEQ expr5 {Beq($1,$2,$3);} ; + | expr4 NMGE expr5 {Bge($1,$2,$3);} ; + | expr4 NMGT expr5 {Bgt($1,$2,$3);} ; + | expr4 NMLE expr5 {Ble($1,$2,$3);} ; + | expr4 NMLT expr5 {Blt($1,$2,$3);} ; + | expr4 NMNE expr5 {Bne($1,$2,$3);} ; + | expr4 EQUIV expr5 {Beqv($1,$2,$3);} ; + | expr4 NEQUIV expr5 {Bneqv($1,$2,$3);} ; + +expr5 : expr6 ; + | expr5 CONCAT expr6 {Bcat($1,$2,$3);} ; + | expr5 LCONCAT expr6 {Blcat($1,$2,$3);} ; + +expr6 : expr7 ; + | expr6 PLUS expr7 {Bplus($1,$2,$3);} ; + | expr6 DIFF expr7 {Bdiff($1,$2,$3);} ; + | expr6 UNION expr7 {Bunion($1,$2,$3);} ; + | expr6 MINUS expr7 {Bminus($1,$2,$3);} ; + +expr7 : expr8 ; + | expr7 STAR expr8 {Bstar($1,$2,$3);} ; + | expr7 INTER expr8 {Binter($1,$2,$3);} ; + | expr7 SLASH expr8 {Bslash($1,$2,$3);} ; + | expr7 MOD expr8 {Bmod($1,$2,$3);} ; + +expr8 : expr9 ; + | expr9 CARET expr8 {Bcaret($1,$2,$3);} ; + +expr9 : expr10 ; + | expr9 BACKSLASH expr10 {Blim($1,$2,$3);} ; + | expr9 AT expr10 {Bact($1,$2,$3);}; + | expr9 BANG expr10 {Apply($1,$2,$3);}; + +expr10 : expr11 ; + | AT expr10 {Uat($1,$2);} ; + | NOT expr10 {Unot($1,$2);} ; + | BAR expr10 {Ubar($1,$2);} ; + | CONCAT expr10 {Uconcat($1,$2);} ; + | LCONCAT expr10 {Ulconcat($1,$2);} ; + | DOT expr10 {Udot($1,$2);} ; + | BANG expr10 {Ubang($1,$2);} ; + | DIFF expr10 {Udiff($1,$2);} ; + | PLUS expr10 {Uplus($1,$2);} ; + | STAR expr10 {Ustar($1,$2);} ; + | SLASH expr10 {Uslash($1,$2);} ; + | CARET expr10 {Ucaret($1,$2);} ; + | INTER expr10 {Uinter($1,$2);} ; + | TILDE expr10 {Utilde($1,$2);} ; + | MINUS expr10 {Uminus($1,$2);} ; + | NMEQ expr10 {Unumeq($1,$2);} ; + | NMNE expr10 {Unumne($1,$2);} ; + | SEQ expr10 {Ulexeq($1,$2);} ; + | SNE expr10 {Ulexne($1,$2);} ; + | EQUIV expr10 {Uequiv($1,$2);} ; + | UNION expr10 {Uunion($1,$2);} ; + | QMARK expr10 {Uqmark($1,$2);} ; + | NEQUIV expr10 {Unotequiv($1,$2);} ; + | BACKSLASH expr10 {Ubackslash($1,$2);} ; + +expr11 : literal ; + | section ; + | return ; + | if ; + | case ; + | while ; + | until ; + | every ; + | repeat ; + | CREATE expr {Create($1,$2);} ; + | IDENT {Var($1);} ; + | NEXT {Next($1);} ; + | BREAK nexpr {Break($1,$2);} ; + | LPAREN exprlist RPAREN {Paren($1,$2,$3);} ; + | LBRACE compound RBRACE {Brace($1,$2,$3);} ; + | LBRACK exprlist RBRACK {Brack($1,$2,$3);} ; + | expr11 LBRACK exprlist RBRACK {Subscript($1,$2,$3,$4);} ; + | expr11 LBRACE RBRACE {Pdco0($1,$2,$3);} ; + | expr11 LBRACE pdcolist RBRACE {Pdco1($1,$2,$3,$4);} ; + | expr11 LPAREN exprlist RPAREN {Invoke($1,$2,$3,$4);} ; + | expr11 DOT IDENT {Field($1,$2,$3);} ; + | AND FAIL {Kfail($1,$2);} ; + | AND IDENT {Keyword($1,$2);} ; + +while : WHILE expr {While0($1,$2);} ; + | WHILE expr DO expr {While1($1,$2,$3,$4);} ; + +until : UNTIL expr {Until0($1,$2);} ; + | UNTIL expr DO expr {Until1($1,$2,$3,$4);} ; + +every : EVERY expr {Every0($1,$2);} ; + | EVERY expr DO expr {Every1($1,$2,$3,$4);} ; + +repeat : REPEAT expr {Repeat($1,$2);} ; + +return : FAIL {Fail($1);} ; + | RETURN nexpr {Return($1,$2);} ; + | SUSPEND nexpr {Suspend0($1,$2);} ; + | SUSPEND expr DO expr {Suspend1($1,$2,$3,$4);}; + +if : IF expr THEN expr {If0($1,$2,$3,$4);} ; + | IF expr THEN expr ELSE expr {If1($1,$2,$3,$4,$5,$6);} ; + +case : CASE expr OF LBRACE caselist RBRACE {Case($1,$2,$3,$4,$5,$6);} ; + +caselist: cclause ; + | caselist SEMICOL cclause {Caselist($1,$2,$3);} ; + +cclause : DEFAULT COLON expr {Cclause0($1,$2,$3);} ; + | expr COLON expr {Cclause1($1,$2,$3);} ; + +exprlist: nexpr {Elst0($1);} + | exprlist COMMA nexpr {Elst1($1,$2,$3);} ; + +pdcolist: nexpr { + Pdcolist0($1); + } ; + | pdcolist COMMA nexpr { + Pdcolist1($1,$2,$3); + } ; + +literal : INTLIT {Iliter($1);} ; + | REALLIT {Rliter($1);} ; + | STRINGLIT {Sliter($1);} ; + | CSETLIT {Cliter($1);} ; + +section : expr11 LBRACK expr sectop expr RBRACK {Section($1,$2,$3,$4,$5,$6);} ; + +sectop : COLON {Colon($1);} ; + | PCOLON {Pcolon($1);} ; + | MCOLON {Mcolon($1);} ; + +compound: nexpr ; + | nexpr SEMICOL compound {Compound($1,$2,$3);} ; + +program : error decls EOFX ; +proc : prochead error procbody END ; +expr : error ; diff --git a/src/h/graphics.h b/src/h/graphics.h new file mode 100644 index 0000000..fa56f79 --- /dev/null +++ b/src/h/graphics.h @@ -0,0 +1,447 @@ +/* + * graphics.h - macros and types used in Icon's graphics interface. + */ + +#ifdef XWindows + #include "../h/xwin.h" +#endif /* XWindows */ + +#ifdef WinGraphics + #include "../h/mswin.h" +#endif /* WinGraphics */ + +#ifndef MAXXOBJS + #define MAXXOBJS 256 +#endif /* MAXXOBJS */ + +#ifndef MAXCOLORNAME + #define MAXCOLORNAME 40 +#endif /* MAXCOLORNAME */ + +#ifndef MAXFONTWORD + #define MAXFONTWORD 40 +#endif /* MAXFONTWORD */ + +#define POLLSLEEP 20 /* milliseconds sleep while awaiting event */ + +#define DEFAULTFONTSIZE 14 + +#define FONTATT_SPACING 0x01000000 +#define FONTFLAG_MONO 0x00000001 +#define FONTFLAG_PROPORTIONAL 0x00000002 + +#define FONTATT_SERIF 0x02000000 +#define FONTFLAG_SANS 0x00000004 +#define FONTFLAG_SERIF 0x00000008 + +#define FONTATT_SLANT 0x04000000 +#define FONTFLAG_ROMAN 0x00000010 +#define FONTFLAG_ITALIC 0x00000020 +#define FONTFLAG_OBLIQUE 0x00000040 + +#define FONTATT_WEIGHT 0x08000000 +#define FONTFLAG_LIGHT 0x00000100 +#define FONTFLAG_MEDIUM 0x00000200 +#define FONTFLAG_DEMI 0x00000400 +#define FONTFLAG_BOLD 0x00000800 + +#define FONTATT_WIDTH 0x10000000 +#define FONTFLAG_CONDENSED 0x00001000 +#define FONTFLAG_NARROW 0x00002000 +#define FONTFLAG_NORMAL 0x00004000 +#define FONTFLAG_WIDE 0x00008000 +#define FONTFLAG_EXTENDED 0x00010000 + +/* + * EVENT HANDLING + * + * Each window keeps an associated queue of events waiting to be + * processed. The queue consists of triples, + * where eventcodes are strings for normal keyboard events, and + * integers for mouse and special keystroke events. + * + * The main queue is an icon list. In addition, there is a queue of + * old keystrokes maintained for cooked mode operations, maintained + * in a little circular array of chars. + */ +#define EQ_MOD_CONTROL (1L<<16L) +#define EQ_MOD_META (1L<<17L) +#define EQ_MOD_SHIFT (1L<<18L) + +#define EVQUESUB(w,i) *evquesub(w,i) +#define EQUEUELEN 256 + +/* + * mode bits for the Icon window context (as opposed to X context) + */ + +#define ISINITIAL(w) ((w)->window->bits & 1) +#define ISINITIALW(ws) ((ws)->bits & 1) +#define ISCURSORON(w) ((w)->window->bits & 2) +#define ISCURSORONW(ws) ((ws->bits) & 2) +#define ISMAPPED(w) ((w)->window->bits & 4) +#define ISREVERSE(w) ((w)->context->bits & 8) +#define ISXORREVERSE(w) ((w)->context->bits & 16) +#define ISXORREVERSEW(w) ((w)->bits & 16) +#define ISCLOSED(w) ((w)->window->bits & 64) +#define ISRESIZABLE(w) ((w)->window->bits & 128) +#define ISEXPOSED(w) ((w)->window->bits & 256) +#define ISCEOLON(w) ((w)->window->bits & 512) +#define ISECHOON(w) ((w)->window->bits & 1024) + +#define SETCURSORON(w) ((w)->window->bits |= 2) +/* 4 is available */ +#define SETMAPPED(w) ((w)->window->bits |= 4) +#define SETREVERSE(w) ((w)->context->bits |= 8) +#define SETXORREVERSE(w) ((w)->context->bits |= 16) +#define SETCLOSED(w) ((w)->window->bits |= 64) +#define SETRESIZABLE(w) ((w)->window->bits |= 128) +#define SETEXPOSED(w) ((w)->window->bits |= 256) +#define SETCEOLON(w) ((w)->window->bits |= 512) +#define SETECHOON(w) ((w)->window->bits |= 1024) + +#define CLRCURSORON(w) ((w)->window->bits &= ~2) +#define CLRMAPPED(w) ((w)->window->bits &= ~4) +#define CLRREVERSE(w) ((w)->context->bits &= ~8) +#define CLRXORREVERSE(w) ((w)->context->bits &= ~16) +#define CLRCLOSED(w) ((w)->window->bits &= ~64) +#define CLRRESIZABLE(w) ((w)->window->bits &= ~128) +#define CLREXPOSED(w) ((w)->window->bits &= ~256) +#define CLRCEOLON(w) ((w)->window->bits &= ~512) +#define CLRECHOON(w) ((w)->window->bits &= ~1024) + +#ifdef XWindows + #define ISZOMBIE(w) ((w)->window->bits & 1) + #define SETZOMBIE(w) ((w)->window->bits |= 1) + #define CLRZOMBIE(w) ((w)->window->bits &= ~1) +#endif /* XWindows */ + +#ifdef WinGraphics + #define ISTOBEHIDDEN(ws) ((ws)->bits & 4096) + #define SETTOBEHIDDEN(ws) ((ws)->bits |= 4096) + #define CLRTOBEHIDDEN(ws) ((ws)->bits &= ~4096) +#endif /* WinGraphics */ + +/* + * Window Resources + * Icon "Resources" are a layer on top of the window system resources, + * provided in order to facilitate resource sharing and minimize the + * number of calls to the window system. Resources are reference counted. + * These data structures are simple sets of pointers + * into internal window system structures. + */ + +/* + * Fonts are allocated within displays. + */ +typedef struct _wfont { + int refcount; + int serial; /* serial # */ + struct _wfont *previous, *next; + char *name; /* name for WAttrib and fontsearch */ + + #ifdef XWindows + int height; /* font height */ + XFontStruct *fsp; /* X font pointer */ + #endif /* XWindows */ + + #ifdef WinGraphics + HFONT font; + LONG ascent; + LONG descent; + LONG charwidth; + LONG height; + #endif /* WinGraphics */ + + } wfont, *wfp; + +/* + * These structures and definitions are used for colors and images. + */ +typedef struct { + long red, green, blue; /* color components, linear 0 - 65535*/ + } LinearColor; + +struct palentry { /* entry for one palette member */ + LinearColor clr; /* RGB value of color */ + char used; /* nonzero if char is used */ + char valid; /* nonzero if entry is valid & opaque */ + char transpt; /* nonzero if char is transparent */ + }; + +struct imgdata { /* image loaded from a file */ + int width, height; /* image dimensions */ + struct palentry *paltbl; /* pointer to palette table */ + unsigned char *data; /* pointer to image data */ + }; + +struct imgmem { + int x, y, width, height; + + #ifdef XWindows + XImage *im; + #endif /* XWindows */ + + #ifdef WinGraphics + COLORREF *crp; + #endif /* WinGraphics */ + }; + +#define TCH1 '~' /* usual transparent character */ +#define TCH2 0377 /* alternate transparent character */ +#define PCH1 ' ' /* punctuation character */ +#define PCH2 ',' /* punctuation character */ + +#define GIFMAX 256 /* maximum colors in a GIF file */ + +#ifdef XWindows +/* + * Displays are maintained in a global list in rwinrsc.r. + */ +typedef struct _wdisplay { + int refcount; + int serial; /* serial # */ + char name[MAXDISPLAYNAME]; + Display * display; + Visual * visual; + GC icongc; + Colormap cmap; + double gamma; + int screen; + int numFonts; + wfp fonts; + int numColors; /* number of allocated color structs */ + int cpSize; /* max number of slots before realloc */ + struct wcolor **colrptrs; /* array of pointers to those colors */ + Cursor cursors[NUMCURSORSYMS]; + struct _wdisplay *previous, *next; + } *wdp; +#endif /* XWindows */ + +/* + * "Context" comprises the graphics context, and the font (i.e. text context). + * Foreground and background colors (pointers into the display color table) + * are stored here to reduce the number of window system queries. + * Contexts are allocated out of a global array in rwinrsrc.c. + */ +typedef struct _wcontext { + int refcount; + int serial; /* serial # */ + struct _wcontext *previous, *next; + int clipx, clipy, clipw, cliph; + char *patternname; + wfp font; + int dx, dy; + int fillstyle; + int drawop; + double gamma; /* gamma correction value */ + int bits; /* context bits */ + + #ifdef XWindows + wdp display; + GC gc; /* X graphics context */ + wclrp fg, bg; + int linestyle; + int linewidth; + int leading; /* inter-line leading */ + #endif /* XWindows */ + + #ifdef WinGraphics + LOGPEN pen; + LOGPEN bgpen; + LOGBRUSH brush; + LOGBRUSH bgbrush; + HRGN cliprgn; + HBITMAP pattern; + SysColor fg, bg; + char *fgname, *bgname; + int leading, bkmode; + #endif /* WinGraphics*/ + + } wcontext, *wcp; + +/* + * Native facilities include the following child controls (windows) that + * persist on the canvas and intercept various events. + */ +#ifdef WinGraphics + #define CHILD_BUTTON 0 + #define CHILD_SCROLLBAR 1 + #define CHILD_EDIT 2 + typedef struct childcontrol { + int type; /* what kind of control? */ + HWND win; /* child window handle */ + HFONT font; + char *id; /* child window string id */ + } childcontrol; +#endif /* WinGraphics */ + +/* + * "Window state" includes the actual X window and references to a large + * number of resources allocated on a per-window basis. Windows are + * allocated out of a global array in rwinrsrc.c. Windows remember the + * first WMAXCOLORS colors they allocate, and deallocate them on clearscreen. + */ +typedef struct _wstate { + int refcount; /* reference count */ + int serial; /* serial # */ + struct _wstate *previous, *next; + int pixheight; /* backing pixmap height, in pixels */ + int pixwidth; /* pixmap width, in pixels */ + char *windowlabel; /* window label */ + char *iconimage; /* icon pixmap file name */ + char *iconlabel; /* icon label */ + struct imgdata initimage; /* initial image data */ + struct imgdata initicon; /* initial icon image data */ + int y, x; /* current cursor location, in pixels*/ + int pointery, pointerx; /* current mouse location, in pixels */ + int posy, posx; /* desired upper lefthand corner */ + unsigned int height; /* window height, in pixels */ + unsigned int width; /* window width, in pixels */ + int bits; /* window bits */ + int theCursor; /* index into cursor table */ + word timestamp; /* last event time stamp */ + char eventQueue[EQUEUELEN]; /* queue of cooked-mode keystrokes */ + int eQfront, eQback; + char *cursorname; + struct descrip filep, listp; /* icon values for this window */ + + #ifdef XWindows + wdp display; + Window win; /* X window */ + Pixmap pix; /* current screen state */ + Pixmap initialPix; /* an initial image to display */ + Window iconwin; /* icon window */ + Pixmap iconpix; /* icon pixmap */ + int normalx, normaly; /* pos to remember when maximized */ + int normalw, normalh; /* size to remember when maximized */ + int numColors; /* allocated color info */ + short *theColors; /* indices into display color table */ + int numiColors; /* allocated color info for the icon */ + short *iconColors; /* indices into display color table */ + int iconic; /* window state; icon, window or root*/ + int iconx, icony; /* location of icon */ + unsigned int iconw, iconh; /* width and height of icon */ + long wmhintflags; /* window manager hints */ + #endif /* XWindows */ + + #ifdef WinGraphics + HWND win; /* client window */ + HWND iconwin; /* client window when iconic */ + HBITMAP pix; /* backing bitmap */ + HBITMAP iconpix; /* backing bitmap */ + HBITMAP initialPix; /* backing bitmap */ + HBITMAP theOldPix; + int hasCaret; + HCURSOR curcursor; + HCURSOR savedcursor; + HMENU menuBar; + int nmMapElems; + char ** menuMap; + HWND focusChild; + int nChildren; + childcontrol *child; + #endif /* WinGraphics */ + + } wstate, *wsp; + +/* + * Icon window file variables are actually pointers to "bindings" + * of a window and a context. They are allocated out of a global + * array in rwinrsrc.c. There is one binding per Icon window value. + */ +typedef struct _wbinding { + int refcount; + int serial; + struct _wbinding *previous, *next; + wcp context; + wsp window; + } wbinding, *wbp; + +/* + * Table entry for string <-> integer mapping. + */ +typedef struct { + char *s; + int i; + } stringint, *siptr; + + +/* + * Gamma Correction value to compensate for nonlinear monitor color response + */ +#ifndef GammaCorrection + #define GammaCorrection 2.5 +#endif /* GammaCorrection */ + +/* + * Attributes + */ +#define A_ASCENT 1 +#define A_BG 2 +#define A_CANVAS 3 +#define A_CEOL 4 +#define A_CLIPH 5 +#define A_CLIPW 6 +#define A_CLIPX 7 +#define A_CLIPY 8 +#define A_COL 9 +#define A_COLUMNS 10 +#define A_CURSOR 11 +#define A_DEPTH 12 +#define A_DESCENT 13 +#define A_DISPLAY 14 +#define A_DISPLAYHEIGHT 15 +#define A_DISPLAYWIDTH 16 +#define A_DRAWOP 17 +#define A_DX 18 +#define A_DY 19 +#define A_ECHO 20 +#define A_FG 21 +#define A_FHEIGHT 22 +#define A_FILLSTYLE 23 +#define A_FONT 24 +#define A_FWIDTH 25 +#define A_GAMMA 26 +#define A_GEOMETRY 27 +#define A_HEIGHT 28 +#define A_ICONIC 29 +#define A_ICONIMAGE 30 +#define A_ICONLABEL 31 +#define A_ICONPOS 32 +#define A_IMAGE 33 +#define A_LABEL 34 +#define A_LEADING 35 +#define A_LINES 36 +#define A_LINESTYLE 37 +#define A_LINEWIDTH 38 +#define A_PATTERN 39 +#define A_POINTERCOL 40 +#define A_POINTERROW 41 +#define A_POINTERX 42 +#define A_POINTERY 43 +#define A_POINTER 44 +#define A_POS 45 +#define A_POSX 46 +#define A_POSY 47 +#define A_RESIZE 48 +#define A_REVERSE 49 +#define A_ROW 50 +#define A_ROWS 51 +#define A_SIZE 52 +#define A_VISUAL 53 +#define A_WIDTH 54 +#define A_WINDOWLABEL 55 +#define A_X 56 +#define A_Y 57 + +#define NUMATTRIBS 57 + +/* + * flags for ConsoleFlags + */ +/* I/O redirection flags */ +#define StdOutRedirect 1 +#define StdErrRedirect 2 +#define StdInRedirect 4 +#define OutputToBuf 8 diff --git a/src/h/grttin.h b/src/h/grttin.h new file mode 100644 index 0000000..1247ca2 --- /dev/null +++ b/src/h/grttin.h @@ -0,0 +1,278 @@ +/* + * Group of include files for input to rtt. + * rtt reads these files for preprocessor directives and typedefs, but + * does not output any code from them. + */ +#include "../h/define.h" +#include "../h/arch.h" +#include "../h/config.h" +#include "../h/version.h" + +#ifndef NoTypeDefs + #include "../h/typedefs.h" +#endif /* NoTypeDefs */ + +/* + * Macros that must be expanded by rtt. + */ + +/* + * Declaration for library routine. + */ +#begdef LibDcl(nm,n,pn) + #passthru OpBlock(nm,n,pn,0) + + int O##nm(nargs,cargp) + int nargs; + register dptr cargp; +#enddef /* LibDcl */ + +/* + * Error exit from non top-level routines. Set tentative values for + * error number and error value; these errors will but put in + * effect if the run-time error routine is called. + */ +#begdef ReturnErrVal(err_num, offending_val, ret_val) + do { + t_errornumber = err_num; + t_errorvalue = offending_val; + t_have_val = 1; + return ret_val; + } while (0) +#enddef /* ReturnErrVal */ + +#begdef ReturnErrNum(err_num, ret_val) + do { + t_errornumber = err_num; + t_errorvalue = nulldesc; + t_have_val = 0; + return ret_val; + } while (0) +#enddef /* ReturnErrNum */ + +/* + * Code expansions for exits from C code for top-level routines. + */ +#define Fail return A_Resume +#define Return return A_Continue + +/* + * RunErr encapsulates a call to the function err_msg, followed + * by Fail. The idea is to avoid the problem of calling + * runerr directly and forgetting that it may actually return. + */ + +#define RunErr(n,dp) do {\ + err_msg((int)n,dp);\ + Fail;\ + } while (0) + +/* + * Protection macro. + */ +#define Protect(notnull,orelse) do {if ((notnull)==NULL) orelse;} while(0) + +#ifdef EventMon +/* + * perform what amounts to "function inlining" of EVVal + */ +#begdef EVVal(value,event) + do { + if (is:null(curpstate->eventmask)) break; + else if (!Testb((word)event, curpstate->eventmask)) break; + MakeInt(value, &(curpstate->parent->eventval)); + actparent(event); + } while (0) +#enddef /* EVVal */ +#begdef EVValD(dp,event) + do { + if (is:null(curpstate->eventmask)) break; + else if (!Testb((word)event, curpstate->eventmask)) break; + curpstate->parent->eventval = *(dp); + actparent(event); + } while (0) +#enddef /* EVValD */ +#begdef EVValX(bp,event) + do { + struct progstate *parent = curpstate->parent; + if (is:null(curpstate->eventmask)) break; + else if (!Testb((word)event, curpstate->eventmask)) break; + parent->eventval.dword = D_Coexpr; + BlkLoc(parent->eventval) = (union block *)(bp); + actparent(event); + } while (0) +#enddef /* EVValX */ + +#define InterpEVVal(arg1,arg2) { ExInterp; EVVal(arg1,arg2); EntInterp; } +#define InterpEVValD(arg1,arg2) { ExInterp; EVValD(arg1,arg2); EntInterp; } +#define InterpEVValX(arg1,arg2) { ExInterp; EVValX(arg1,arg2); EntInterp; } + +/* + * Macro with construction of event descriptor. + */ + +#begdef Desc_EVValD(bp, code, type) + do { + eventdesc.dword = type; + eventdesc.vword.bptr = (union block *)(bp); + EVValD(&eventdesc, code); + } while (0) +#enddef /* Desc_EVValD */ + +#else /* EventMon */ + #define EVVal(arg1,arg2) + #define EVValD(arg1,arg2) + #define EVValX(arg1,arg2) + #define InterpEVVal(arg1,arg2) + #define InterpEVValD(arg1,arg2) + #define InterpEVValX(arg1,arg2) + #define Desc_EVValD(bp, code, type) +#endif /* EventMon */ + +/* + * dummy typedefs for things defined in #include files + */ +typedef int clock_t, time_t, fd_set; + +#ifdef ReadDirectory + typedef int DIR; +#endif /* ReadDirectory */ + +/* + * graphics + */ +#ifdef Graphics + typedef int wbp, wsp, wcp, wdp, wclrp, wfp; + typedef int wbinding, wstate, wcontext, wfont; + typedef int siptr, stringint; + typedef int XRectangle, XPoint, XSegment, XArc, SysColor, LinearColor; + typedef int LONG, SHORT; + + #ifdef XWindows + typedef int Atom, Time, XSelectionEvent, XErrorEvent, XErrorHandler; + typedef int XGCValues, XColor, XFontStruct, XWindowAttributes, XEvent; + typedef int XExposeEvent, XKeyEvent, XButtonEvent, XConfigureEvent; + typedef int XSizeHints, XWMHints, XClassHint, XTextProperty; + typedef int Colormap, XVisualInfo, va_list; + typedef int *Display, Cursor, GC, Window, Pixmap, Visual, KeySym; + typedef int WidgetClass, XImage, XpmAttributes; + #endif /* XWindows */ + + #ifdef WinGraphics + typedef int clock_t, jmp_buf, MINMAXINFO, OSVERSIONINFO, BOOL_CALLBACK; + typedef int int_PASCAL, LRESULT_CALLBACK, MSG, BYTE, WORD, DWORD; + typedef int HINSTANCE, LPSTR, HBITMAP, WNDCLASS, PAINTSTRUCT, POINT, RECT; + typedef int HWND, HDC, UINT, WPARAM, LPARAM, HANDLE, HPEN, HBRUSH, SIZE; + typedef int COLORREF, HFONT, LOGFONT, TEXTMETRIC, FONTENUMPROC, FARPROC; + typedef int LOGPALETTE, HPALETTE, PALETTEENTRY, HCURSOR, BITMAP, HDIB; + typedef int va_list, LOGPEN, LOGBRUSH, LPVOID, MCI_PLAY_PARMS; + typedef int MCI_OPEN_PARMS, MCI_STATUS_PARMS, MCI_SEQ_SET_PARMS; + typedef int CHOOSEFONT, CHOOSECOLOR, OPENFILENAME, HMENU, LPBITMAPINFO; + typedef int childcontrol, CPINFO, BITMAPINFO, BITMAPINFOHEADER, RGBQUAD; + typedef int BOOL, LPMSG, STARTUPINFO; + #endif /* WinGraphics */ + + /* + * Convenience macros to make up for RTL's long-windedness. + */ + #begdef CnvCShort(desc, s) + { + C_integer tmp; + if (!cnv:C_integer(desc,tmp) || tmp > 0x7FFF || tmp < -0x8000) + runerr(101,desc); + s = (short) tmp; + } + #enddef /* CnvCShort */ + + #define CnvCInteger(d,i) \ + if (!cnv:C_integer(d,i)) runerr(101,d); + + #define DefCInteger(d,default,i) \ + if (!def:C_integer(d,default,i)) runerr(101,d); + + #define CnvString(din,dout) \ + if (!cnv:string(din,dout)) runerr(103,din); + + #define CnvTmpString(din,dout) \ + if (!cnv:tmp_string(din,dout)) runerr(103,din); + + /* + * conventions supporting optional initial window arguments: + * + * All routines declare argv[argc] as their parameters + * Macro OptWindow checks argv[0] and assigns _w_ and warg if it is a window + * warg serves as a base index and is added everywhere argv is indexed + * n is used to denote the actual number of "objects" in the call + * Macro ReturnWindow returns either the initial window argument, or &window + */ + #begdef OptWindow(w) + if (argc>warg && is:file(argv[warg])) { + if ((BlkLoc(argv[warg])->file.status & Fs_Window) == 0) + runerr(140,argv[warg]); + if ((BlkLoc(argv[warg])->file.status & (Fs_Read|Fs_Write)) == 0) + runerr(142,argv[warg]); + (w) = (wbp)BlkLoc(argv[warg])->file.fd; + if (ISCLOSED(w)) + runerr(142,argv[warg]); + warg++; + } + else { + if (!(is:file(kywd_xwin[XKey_Window]) && + (BlkLoc(kywd_xwin[XKey_Window])->file.status & Fs_Window))) + runerr(140,kywd_xwin[XKey_Window]); + if (!(BlkLoc(kywd_xwin[XKey_Window])->file.status&(Fs_Read|Fs_Write))) + runerr(142,kywd_xwin[XKey_Window]); + (w) = (wbp)BlkLoc(kywd_xwin[XKey_Window])->file.fd; + if (ISCLOSED(w)) + runerr(142,kywd_xwin[XKey_Window]); + } + #enddef /* OptWindow */ + + #begdef ReturnWindow + if (!warg) return kywd_xwin[XKey_Window]; + else return argv[0] + #enddef /* ReturnWindow */ + + #begdef CheckArgMultiple(mult) + { + if ((argc-warg) % (mult)) runerr(146); + n = (argc-warg)/mult; + if (!n) runerr(146); + } + #enddef /* CheckArgMultiple */ + + /* + * calloc to make sure uninit'd entries are zeroed. + */ + #begdef GRFX_ALLOC(var,type) + do { + var = (struct type *)calloc(1, sizeof(struct type)); + if (var == NULL) ReturnErrNum(305, NULL); + var->refcount = 1; + } while(0) + #enddef /* GRFX_ALLOC */ + + #begdef GRFX_LINK(var, chain) + do { + var->next = chain; + var->previous = NULL; + if (chain) chain->previous = var; + chain = var; + } while(0) + #enddef /* GRFX_LINK */ + + #begdef GRFX_UNLINK(var, chain) + do { + if (var->previous) var->previous->next = var->next; + else chain = var->next; + if (var->next) var->next->previous = var->previous; + free(var); + } while(0) + #enddef /* GRFX_UNLINK */ + +#endif /* Graphics */ + +#ifdef FAttrib + typedef unsigned long mode_t; + typedef int HFILE, OFSTRUCT, FILETIME, SYSTEMTIME; +#endif /* FAttrib */ diff --git a/src/h/gsupport.h b/src/h/gsupport.h new file mode 100644 index 0000000..d56f1d0 --- /dev/null +++ b/src/h/gsupport.h @@ -0,0 +1,13 @@ +/* + * Group of include files for translators, etc. + */ + +#include "../h/define.h" + +#include "../h/arch.h" +#include "../h/config.h" +#include "../h/sys.h" +#include "../h/typedefs.h" +#include "../h/cstructs.h" +#include "../h/mproto.h" +#include "../h/cpuconf.h" diff --git a/src/h/header.h b/src/h/header.h new file mode 100644 index 0000000..3b131f1 --- /dev/null +++ b/src/h/header.h @@ -0,0 +1,28 @@ +/* + * Interpreter code file header - this is written at the start of + * an icode file after the start-up program. + */ +struct header { + word hsize; /* size of interpreter code */ + word trace; /* initial value of &trace */ + + word Records; + word Ftab; /* location of record/field table */ + word Fnames; /* location of names of fields */ + word Globals; /* location of global variables */ + word Gnames; /* location of names of globals */ + word Statics; /* location of static variables */ + word Strcons; /* location of identifier table */ + word Filenms; /* location of ipc/file name table */ + + #ifdef FieldTableCompression + short FtabWidth; /* width of field table entries, 1 | 2 | 4 */ + short FoffWidth; /* width of field offset entries, 1 | 2 | 4 */ + word Nfields; /* number of field names */ + word Fo; /* The start of the Fo array */ + word Bm; /* The start of the Bm array */ + #endif /* FieldTableCompression */ + + word linenums; /* location of ipc/line number table */ + word config[16]; /* icode version */ + }; diff --git a/src/h/kdefs.h b/src/h/kdefs.h new file mode 100644 index 0000000..752841f --- /dev/null +++ b/src/h/kdefs.h @@ -0,0 +1,70 @@ +/* + * ../h/kdefs.h -- Keyword list. + * + * Created mechanically by mkkwd.icn -- DO NOT EDIT. + */ + +KDef(allocated,K_ALLOCATED) +KDef(ascii,K_ASCII) +KDef(clock,K_CLOCK) +KDef(col,K_COL) +KDef(collections,K_COLLECTIONS) +KDef(column,K_COLUMN) +KDef(control,K_CONTROL) +KDef(cset,K_CSET) +KDef(current,K_CURRENT) +KDef(date,K_DATE) +KDef(dateline,K_DATELINE) +KDef(digits,K_DIGITS) +KDef(dump,K_DUMP) +KDef(e,K_E) +KDef(error,K_ERROR) +KDef(errornumber,K_ERRORNUMBER) +KDef(errortext,K_ERRORTEXT) +KDef(errorvalue,K_ERRORVALUE) +KDef(errout,K_ERROUT) +KDef(eventcode,K_EVENTCODE) +KDef(eventsource,K_EVENTSOURCE) +KDef(eventvalue,K_EVENTVALUE) +KDef(fail,K_FAIL) +KDef(features,K_FEATURES) +KDef(file,K_FILE) +KDef(host,K_HOST) +KDef(input,K_INPUT) +KDef(interval,K_INTERVAL) +KDef(lcase,K_LCASE) +KDef(ldrag,K_LDRAG) +KDef(letters,K_LETTERS) +KDef(level,K_LEVEL) +KDef(line,K_LINE) +KDef(lpress,K_LPRESS) +KDef(lrelease,K_LRELEASE) +KDef(main,K_MAIN) +KDef(mdrag,K_MDRAG) +KDef(meta,K_META) +KDef(mpress,K_MPRESS) +KDef(mrelease,K_MRELEASE) +KDef(null,K_NULL) +KDef(output,K_OUTPUT) +KDef(phi,K_PHI) +KDef(pi,K_PI) +KDef(pos,K_POS) +KDef(progname,K_PROGNAME) +KDef(random,K_RANDOM) +KDef(rdrag,K_RDRAG) +KDef(regions,K_REGIONS) +KDef(resize,K_RESIZE) +KDef(row,K_ROW) +KDef(rpress,K_RPRESS) +KDef(rrelease,K_RRELEASE) +KDef(shift,K_SHIFT) +KDef(source,K_SOURCE) +KDef(storage,K_STORAGE) +KDef(subject,K_SUBJECT) +KDef(time,K_TIME) +KDef(trace,K_TRACE) +KDef(ucase,K_UCASE) +KDef(version,K_VERSION) +KDef(window,K_WINDOW) +KDef(x,K_X) +KDef(y,K_Y) diff --git a/src/h/lexdef.h b/src/h/lexdef.h new file mode 100644 index 0000000..25ff909 --- /dev/null +++ b/src/h/lexdef.h @@ -0,0 +1,75 @@ +/* + * lexdef.h -- common definitions for use with the lexical analyzer. + */ + +/* + * Miscellaneous globals. + */ +extern int yychar; /* parser's current input token type */ +extern int yynerrs; /* number of errors in parse */ +extern int nocode; /* true to suppress code generation */ + +extern int in_line; /* current line number in input */ +extern int incol; /* current column number in input */ +extern int peekc; /* one character look-ahead */ +extern FILE *srcfile; /* current input file */ + +extern int tfatals; /* total fatal errors */ + +/* + * Token table structure. + */ + +struct toktab { + char *t_word; /* token */ + int t_type; /* token type returned by yylex */ + int t_flags; /* flags for semicolon insertion */ + }; + +extern struct toktab toktab[]; /* token table */ +extern struct toktab *restab[]; /* reserved word index */ + +#define T_Ident &toktab[0] +#define T_Int &toktab[1] +#define T_Real &toktab[2] +#define T_String &toktab[3] +#define T_Cset &toktab[4] +#define T_Eof &toktab[5] + +/* + * t_flags values for token table. + */ + +#define Beginner 1 /* token can follow a semicolon */ +#define Ender 2 /* token can precede a semicolon */ + +/* + * optab contains token information along with pointers to implementation + * information for each operator. Special symbols are also included. + */ +#define Unary 1 +#define Binary 2 + +struct optab { + struct toktab tok; /* token information for the operator symbol */ + int expected; /* what is expected in data base: Unary/Binary */ + struct implement *unary; /* data base entry for unary version */ + struct implement *binary; /* data base entry for binary version */ + }; + +extern struct optab optab[]; /* operator table */ +extern int asgn_loc; /* index in optab of assignment */ +extern int semicol_loc; /* index in optab of semicolon */ +extern int plus_loc; /* index in optab of addition */ +extern int minus_loc; /* index in optab of subtraction */ + +/* + * Miscellaneous. + */ + +#define isoctal(c) ((c)>='0'&&(c)<='7') /* macro to test for octal digit */ +#define NextChar nextchar() /* macro to get next character */ +#define PushChar(c) peekc=(c) /* macro to push back a character */ + +#define Comment '#' /* comment beginner */ +#define Escape '\\' /* string literal escape character */ diff --git a/src/h/monitor.h b/src/h/monitor.h new file mode 100644 index 0000000..e359e9e --- /dev/null +++ b/src/h/monitor.h @@ -0,0 +1,213 @@ +/* + * This file contains definitions for the various event codes and values + * that go to make up event streams. + */ + +/* + * Note: the blank character should *not* be used as an event code. + */ + +#ifdef EventMon + +/* + * Allocation events use lowercase codes. + */ +#define E_Lrgint '\114' /* Large integer allocation */ +#define E_Real '\144' /* Real allocation */ +#define E_Cset '\145' /* Cset allocation */ +#define E_File '\147' /* File allocation */ +#define E_Record '\150' /* Record allocation */ +#define E_Tvsubs '\151' /* Substring tv allocation */ +#define E_External '\152' /* External allocation */ +#define E_List '\153' /* List allocation */ +#define E_Lelem '\155' /* List element allocation */ +#define E_Table '\156' /* Table allocation */ +#define E_Telem '\157' /* Table element allocation */ +#define E_Tvtbl '\160' /* Table-element tv allocation */ +#define E_Set '\161' /* Set allocation */ +#define E_Selem '\164' /* Set element allocation */ +#define E_Slots '\167' /* Hash header allocation */ +#define E_Coexpr '\170' /* Co-expression allocation */ +#define E_Refresh '\171' /* Refresh allocation */ +#define E_Alien '\172' /* Alien allocation */ +#define E_Free '\132' /* Free region */ +#define E_String '\163' /* String allocation */ + +/* + * Some other monitoring codes. + */ +#define E_BlkDeAlc '\055' /* Block deallocation */ +#define E_StrDeAlc '\176' /* String deallocation */ + +/* + * These are not "events"; they are provided for uniformity in tools + * that deal with types. + */ +#define E_Integer '\100' /* Integer value pseudo-event */ +#define E_Null '\044' /* Null value pseudo-event */ +#define E_Proc '\045' /* Procedure value pseudo-event */ +#define E_Kywdint '\136' /* Integer keyword value pseudo-event */ +#define E_Kywdpos '\046' /* Position value pseudo-event */ +#define E_Kywdsubj '\052' /* Subject value pseudo-event */ + +/* + * Codes for main sequence events + */ + + /* + * Timing events + */ +#define E_Tick '\056' /* Clock tick */ + + /* + * Code-location event + */ +#define E_Loc '\174' /* Location change */ +#define E_Line '\355' /* Line change */ + + /* + * Virtual-machine instructions + */ +#define E_Opcode '\117' /* Virtual-machine instruction */ + + /* + * Type-conversion events + */ +#define E_Aconv '\111' /* Conversion attempt */ +#define E_Tconv '\113' /* Conversion target */ +#define E_Nconv '\116' /* Conversion not needed */ +#define E_Sconv '\121' /* Conversion success */ +#define E_Fconv '\112' /* Conversion failure */ + + /* + * Structure events + */ +#define E_Lbang '\301' /* List generation */ +#define E_Lcreate '\302' /* List creation */ +#define E_Lget '\356' /* List get/pop -- only E_Lget used */ +#define E_Lpop '\356' /* List get/pop */ +#define E_Lpull '\304' /* List pull */ +#define E_Lpush '\305' /* List push */ +#define E_Lput '\306' /* List put */ +#define E_Lrand '\307' /* List random reference */ +#define E_Lref '\310' /* List reference */ +#define E_Lsub '\311' /* List subscript */ +#define E_Rbang '\312' /* Record generation */ +#define E_Rcreate '\313' /* Record creation */ +#define E_Rrand '\314' /* Record random reference */ +#define E_Rref '\315' /* Record reference */ +#define E_Rsub '\316' /* Record subscript */ +#define E_Sbang '\317' /* Set generation */ +#define E_Screate '\320' /* Set creation */ +#define E_Sdelete '\321' /* Set deletion */ +#define E_Sinsert '\322' /* Set insertion */ +#define E_Smember '\323' /* Set membership */ +#define E_Srand '\336' /* Set random reference */ +#define E_Sval '\324' /* Set value */ +#define E_Tbang '\325' /* Table generation */ +#define E_Tcreate '\326' /* Table creation */ +#define E_Tdelete '\327' /* Table deletion */ +#define E_Tinsert '\330' /* Table insertion */ +#define E_Tkey '\331' /* Table key generation */ +#define E_Tmember '\332' /* Table membership */ +#define E_Trand '\337' /* Table random reference */ +#define E_Tref '\333' /* Table reference */ +#define E_Tsub '\334' /* Table subscript */ +#define E_Tval '\335' /* Table value */ + + /* + * Scanning events + */ + +#define E_Snew '\340' /* Scanning environment creation */ +#define E_Sfail '\341' /* Scanning failure */ +#define E_Ssusp '\342' /* Scanning suspension */ +#define E_Sresum '\343' /* Scanning resumption */ +#define E_Srem '\344' /* Scanning environment removal */ +#define E_Spos '\346' /* Scanning position */ + + /* + * Assignment + */ + +#define E_Assign '\347' /* Assignment */ +#define E_Value '\350' /* Value assigned */ + + /* + * Sub-string assignment + */ + +#define E_Ssasgn '\354' /* Sub-string assignment */ + /* + * Interpreter stack events + */ + +#define E_Intcall '\351' /* interpreter call */ +#define E_Intret '\352' /* interpreter return */ +#define E_Stack '\353' /* stack depth */ + + /* + * Expression events + */ +#define E_Ecall '\143' /* Call of operation */ +#define E_Efail '\146' /* Failure from expression */ +#define E_Bsusp '\142' /* Suspension from operation */ +#define E_Esusp '\141' /* Suspension from alternation */ +#define E_Lsusp '\154' /* Suspension from limitation */ +#define E_Eresum '\165' /* Resumption of expression */ +#define E_Erem '\166' /* Removal of a suspended generator */ + + /* + * Co-expression events + */ + +#define E_Coact '\101' /* Co-expression activation */ +#define E_Coret '\102' /* Co-expression return */ +#define E_Cofail '\104' /* Co-expression failure */ + + /* + * Procedure events + */ + +#define E_Pcall '\103' /* Procedure call */ +#define E_Pfail '\106' /* Procedure failure */ +#define E_Pret '\122' /* Procedure return */ +#define E_Psusp '\123' /* Procedure suspension */ +#define E_Presum '\125' /* Procedure resumption */ +#define E_Prem '\126' /* Suspended procedure removal */ + +#define E_Fcall '\072' /* Function call */ +#define E_Ffail '\115' /* Function failure */ +#define E_Fret '\120' /* Function return */ +#define E_Fsusp '\127' /* Function suspension */ +#define E_Fresum '\131' /* Function resumption */ +#define E_Frem '\133' /* Function suspension removal */ + +#define E_Ocall '\134' /* Operator call */ +#define E_Ofail '\135' /* Operator failure */ +#define E_Oret '\140' /* Operator return */ +#define E_Osusp '\173' /* Operator suspension */ +#define E_Oresum '\175' /* Operator resumption */ +#define E_Orem '\177' /* Operator suspension removal */ + + /* + * Garbage collections + */ + +#define E_Collect '\107' /* Garbage collection */ +#define E_EndCollect '\360' /* End of garbage collection */ +#define E_TenureString '\361' /* Tenure a string region */ +#define E_TenureBlock '\362' /* Tenure a block region */ + +/* + * Termination Events + */ +#define E_Error '\105' /* Run-time error */ +#define E_Exit '\130' /* Program exit */ + + /* + * I/O events + */ +#define E_MXevent '\370' /* monitor input event */ + +#endif /* EventMon */ diff --git a/src/h/mproto.h b/src/h/mproto.h new file mode 100644 index 0000000..f6f633b --- /dev/null +++ b/src/h/mproto.h @@ -0,0 +1,54 @@ +/* + * mproto.h -- prototypes for functions common to several modules. + */ + +#define NewStruct(type) alloc(sizeof(struct type)) + +pointer alloc (unsigned int n); +unsigned short *bitvect (char *image, int len); +char *canonize (char *path); +void clear_sbuf (struct str_buf *sbuf); +int cmp_pre (char *pre1, char *pre2); +void cset_init (FILE *f, unsigned short *bv); +void db_chstr (char *s1, char *s2); +void db_close (void); +void db_code (struct implement *ip); +void db_dscrd (struct implement *ip); +void db_err1 (int fatal, char *s1); +void db_err2 (int fatal, char *s1, char *s2); +struct implement *db_ilkup (char *id, struct implement **tbl); +struct implement *db_impl (int oper_typ); +int db_open (char *s, char **lrgintflg); +char *db_string (void); +int db_tbl (char *section, struct implement **tbl); +char *findexe (char *name, char *buf, size_t len); +char *findonpath (char *name, char *buf, size_t len); +char *followsym (char *name, char *buf, size_t len); +struct fileparts *fparse(char *s); +void free_stbl (void); +void id_comment (FILE *f); +void init_sbuf (struct str_buf *sbuf); +void init_str (void); +long longwrite (char *s, long len, FILE *file); +char *makename (char *dest, char *d, char *name, char *e); +long millisec (void); +struct il_code *new_il (int il_type, int size); +void new_sbuf (struct str_buf *sbuf); +void nxt_pre (char *pre, char *nxt, int n); +char *pathfind (char *buf, char *path, char *name, char *extn); +int ppch (void); +void ppdef (char *name, char *value); +void ppecho (void); +int ppinit (char *fname, char *inclpath, int m4flag); +int prt_i_str (FILE *f, char *s, int len); +char *relfile (char *prog, char *mod); +char *salloc (char *s); +int smatch (char *s, char *t); +char *spec_str (char *s); +char *str_install (struct str_buf *sbuf); +int tonum (int c); +void lear_sbuf (struct str_buf *sbuf); + +#ifndef SysOpt + int getopt (int argc, char * const argv[], const char *optstring); +#endif /* NoSysOpt */ diff --git a/src/h/mswin.h b/src/h/mswin.h new file mode 100644 index 0000000..2734cb1 --- /dev/null +++ b/src/h/mswin.h @@ -0,0 +1,201 @@ +/* + * mswin.h - macros and types used in the MS Windows graphics interface. + */ + +#define DRAWOP_AND R2_MASKPEN +#define DRAWOP_ANDINVERTED R2_MASKNOTPEN +#define DRAWOP_ANDREVERSE R2_NOTMASKPEN +#define DRAWOP_CLEAR R2_BLACK +#define DRAWOP_COPY R2_COPYPEN +#define DRAWOP_COPYINVERTED R2_NOTCOPYPEN +#define DRAWOP_EQUIV R2_NOTXORPEN +#define DRAWOP_INVERT R2_NOT +#define DRAWOP_NAND R2_MASKNOTPEN +#define DRAWOP_NOOP R2_NOP +#define DRAWOP_NOR R2_MERGENOTPEN +#define DRAWOP_OR R2_MERGEPEN +#define DRAWOP_ORINVERTED R2_MERGEPENNOT +#define DRAWOP_ORREVERSE R2_NOTMERGEPEN +#define DRAWOP_REVERSE R2_USER1 +#define DRAWOP_SET R2_WHITE +#define DRAWOP_XOR R2_XORPEN + +#define TEXTWIDTH(w,s,n) textWidth(w, s, n) +#define SCREENDEPTH(w) getdepth(w) +#define ASCENT(w) ((w)->context->font->ascent) +#define ASCENTC(wc) ((wc)->font->ascent) +#define DESCENT(w) ((w)->context->font->descent) +#define LEADING(w) ((w)->context->leading) +#define FHEIGHT(w) ((w)->context->font->height) +#define FHEIGHTC(wc) ((wc)->font->height) +#define FWIDTH(w) ((w)->context->font->charwidth) +#define FWIDTHC(wc) ((wc)->font->charwidth) +#define LINEWIDTH(w) ((w)->context->pen.lopnWidth.x) +#define DISPLAYHEIGHT(w) devicecaps(w, VERTRES) +#define DISPLAYWIDTH(w) devicecaps(w, HORZRES) +#define wsync(w) /* noop */ +#define SysColor unsigned long +#define RED(x) GetRValue(x) +#define GREEN(x) GetGValue(x) +#define BLUE(x) GetBValue(x) +#define ARCWIDTH(arc) (arc).width +#define ARCHEIGHT(arc) (arc).height +/* + * These get fixed up in the window-system-specific code + */ +#define RECX(rec) (rec).left +#define RECY(rec) (rec).top +#define RECWIDTH(rec) (rec).right +#define RECHEIGHT(rec) (rec).bottom +/* + * + */ +#define ANGLE(ang) (ang) +#define EXTENT(ang) (ang) +#define FULLARC 2 * Pi +#define ISICONIC(w) (IsIconic((w)->window->iconwin)) +#define ISFULLSCREEN(w) 0 +#define ISROOTWIN(w) (0) 0 +#define ISNORMALWINDOW(w) 0 +#define ICONFILENAME(w) "" +#define ICONLABEL(w) ((w)->window->iconlabel) +#define WINDOWLABEL(w) ((w)->window->windowlabel) + +#define MAXDESCENDER(w) DESCENT(w) + +/* + * gemeotry bitmasks + */ +#define GEOM_WIDTH 1 +#define GEOM_HEIGHT 2 +#define GEOM_POSX 4 +#define GEOM_POSY 8 +/* + * fill styles + */ +#define FS_SOLID 1 +#define FS_STIPPLE 2 +#define FS_OPAQUESTIPPLE 4 +/* + * the special ROP code for mode reverse + */ +#define R2_USER1 (R2_LAST << 1) +/* + * window states + */ +#define WS_NORMAL 0 +#define WS_MIN 1 +#define WS_MAX 2 + +/* + * input masks + */ +#define PointerMotionMask 1 + +/* + * something I think should be #defined + */ +#define EOS '\0' + +/* size of the working buffer, used for dialog messages and such */ +#define PMSTRBUFSIZE 2048 +/* + * the bitmasks for the modifier keys + */ +#define ControlMask (1L << 16L) +#define Mod1Mask (2L << 16L) +#define ShiftMask (4L << 16L) +#define VirtKeyMask (8L << 16L) + +/* some macros for Windows */ + +#define MAKERGB(r,g,b) RGB(r,g,b) +#define RGB16TO8(x) if ((x) > 0xff) (x) = (((x) >> 8) & 0xff) +#define hidecrsr(ws) if (ws->hasCaret) HideCaret(ws->iconwin) +#define showcrsr(ws) if (ws->hasCaret) ShowCaret(ws->iconwin) +#define FNTWIDTH(size) ((size) & 0xFFFF) +#define FNTHEIGHT(size) ((size) >> 16) +#define MAKEFNTSIZE(height, width) (((height) << 16) | (width)) +#define WaitForEvent(msgnum, msgstruc) ObtainEvents(NULL, WAIT_EVT, msgnum, msgstruc) + +/* + * "get" means remove them from the Icon list and put them on the ghost que + */ +#define EVQUEGET(ws,d) { \ + int i;\ + if (!c_get((struct b_list *)BlkLoc((ws)->listp),&d)) fatalerr(0,NULL); \ + if (Qual(d)) {\ + (ws)->eventQueue[(ws)->eQfront++] = *StrLoc(d); \ + if ((ws)->eQfront >= EQUEUELEN) (ws)->eQfront = 0; \ + (ws)->eQback = (ws)->eQfront; \ + } \ + } +#define EVQUEEMPTY(ws) (BlkLoc((ws)->listp)->list.size == 0) + +#define SHARED 0 +#define MUTABLE 1 +#define MAXCOLORNAME 40 +/* + * color structure, inspired by X code (xwin.h) + */ +typedef struct wcolor { + int refcount; + char name[6+MAXCOLORNAME]; /* name for WAttrib & WColor reads */ + SysColor c; + int type; /* SHARED or MUTABLE */ +} *wclrp; + +/* + * we make the segment structure look like this so that we can + * cast it to POINTL structures that can be passed to GpiPolyLineDisjoint + */ +typedef struct { + LONG x1, y1; + LONG x2, y2; + } XSegment; + +typedef POINT XPoint; +typedef RECT XRectangle; + +typedef struct { + LONG x, y; + LONG width, height; + double angle1, angle2; + } XArc; + +/* + * macros performing row/column to pixel y,x translations + * computation is 1-based and depends on the current font's size. + * exception: XTOCOL as defined is 0-based, because that's what its + * clients seem to need. + */ +#define ROWTOY(wb, row) ((row - 1) * LEADING(wb) + ASCENT(wb)) +#define COLTOX(wb, col) ((col - 1) * FWIDTH(wb)) +#define YTOROW(wb, y) (((y) - ASCENT(w)) / LEADING(wb) + 1) +#define XTOCOL(w,x) (!FWIDTH(w) ? (x) : ((x) / FWIDTH(w))) + +/* + * system size values + */ +#define BORDERWIDTH (GetSystemMetrics(SM_CXBORDER)) /* 1 */ +#define BORDERHEIGHT (GetSystemMetrics(SM_CYBORDER)) /* 1 */ +#define TITLEHEIGHT (GetSystemMetrics(SM_CYCAPTION)) /* 20 */ +#define FRAMEWIDTH (GetSystemMetrics(SM_CXFRAME)) /* 4 */ +#define FRAMEHEIGHT (GetSystemMetrics(SM_CYFRAME)) /* 4 */ + +#define STDLOCALS(w) \ + wcp wc = (w)->context;\ + wsp ws = (w)->window;\ + HWND stdwin = ws->win;\ + HBITMAP stdpix = ws->pix;\ + HDC stddc = CreateWinDC(w);\ + HDC pixdc = CreatePixDC(w, stddc); + +#define STDFONT \ + { if(stdwin)SelectObject(stddc, wc->font->font); SelectObject(pixdc,wc->font->font); } + +#define FREE_STDLOCALS(w) do { SelectObject(pixdc, (w)->window->theOldPix); ReleaseDC((w)->window->iconwin, stddc); DeleteDC(pixdc); } while (0) + +#define MAXXOBJS 8 + +#define GammaCorrection 1.0 diff --git a/src/h/odefs.h b/src/h/odefs.h new file mode 100644 index 0000000..acb9981 --- /dev/null +++ b/src/h/odefs.h @@ -0,0 +1,54 @@ +/* + * Operator definitions. + * + * Fields are: + * name + * number of arguments + * string representation + * dereference arguments flag: -1 = don't, 0 = do + */ + +OpDef(asgn,2,":=",-1) +OpDef(bang,1,"!",-1) +OpDef(cater,2,"||",0) +OpDef(compl,1,"~",0) +OpDef(diff,2,"--",0) +OpDef(divide,2,"/",0) +OpDef(eqv,2,"===",0) +OpDef(inter,2,"**",0) +OpDef(lconcat,2,"|||",0) +OpDef(lexeq,2,"==",0) +OpDef(lexge,2,">>=",0) +OpDef(lexgt,2,">>",0) +OpDef(lexle,2,"<<=",0) +OpDef(lexlt,2,"<<",0) +OpDef(lexne,2,"~==",0) +OpDef(minus,2,"-",0) +OpDef(mod,2,"%",0) +OpDef(mult,2,"*",0) +OpDef(neg,1,"-",0) +OpDef(neqv,2,"~===",0) +OpDef(nonnull,1,"\\",-1) +OpDef(null,1,"/",-1) +OpDef(number,1,"+",0) +OpDef(numeq,2,"=",0) +OpDef(numge,2,">=",0) +OpDef(numgt,2,">",0) +OpDef(numle,2,"<=",0) +OpDef(numlt,2,"<",0) +OpDef(numne,2,"~=",0) +OpDef(plus,2,"+",0) +OpDef(powr,2,"^",0) +OpDef(random,1,"?",-1) +OpDef(rasgn,2,"<-",-1) +OpDef(refresh,1,"^",0) +OpDef(rswap,2,"<->",-1) +OpDef(sect,3,"[:]",-1) +OpDef(size,1,"*",0) +OpDef(subsc,2,"[]",-1) +OpDef(swap,2,":=:",-1) +OpDef(tabmat,1,"=",0) +OpDef(toby,3,"...",0) +OpDef(union,2,"++",0) +OpDef(value,1,".",0) +/* OpDef(llist,1,"[...]",0) */ diff --git a/src/h/opdefs.h b/src/h/opdefs.h new file mode 100644 index 0000000..8f32e30 --- /dev/null +++ b/src/h/opdefs.h @@ -0,0 +1,140 @@ +/* + * Opcode definitions used in icode. + */ + +/* + * Operators. These must be in the same order as in odefs.h. Not very nice, + * but it'll have to do until we think of another way to do this. (It's + * always been thus.) + */ +#define Op_Asgn 1 +#define Op_Bang 2 +#define Op_Cat 3 +#define Op_Compl 4 +#define Op_Diff 5 +#define Op_Div 6 +#define Op_Eqv 7 +#define Op_Inter 8 +#define Op_Lconcat 9 +#define Op_Lexeq 10 +#define Op_Lexge 11 +#define Op_Lexgt 12 +#define Op_Lexle 13 +#define Op_Lexlt 14 +#define Op_Lexne 15 +#define Op_Minus 16 +#define Op_Mod 17 +#define Op_Mult 18 +#define Op_Neg 19 +#define Op_Neqv 20 +#define Op_Nonnull 21 +#define Op_Null 22 +#define Op_Number 23 +#define Op_Numeq 24 +#define Op_Numge 25 +#define Op_Numgt 26 +#define Op_Numle 27 +#define Op_Numlt 28 +#define Op_Numne 29 +#define Op_Plus 30 +#define Op_Power 31 +#define Op_Random 32 +#define Op_Rasgn 33 +#define Op_Refresh 34 +#define Op_Rswap 35 +#define Op_Sect 36 +#define Op_Size 37 +#define Op_Subsc 38 +#define Op_Swap 39 +#define Op_Tabmat 40 +#define Op_Toby 41 +#define Op_Unions 42 +#define Op_Value 43 +/* + * Other instructions. + */ +#define Op_Bscan 44 +#define Op_Ccase 45 +#define Op_Chfail 46 +#define Op_Coact 47 +#define Op_Cofail 48 +#define Op_Coret 49 +#define Op_Create 50 +#define Op_Cset 51 +#define Op_Dup 52 +#define Op_Efail 53 +#define Op_Eret 54 +#define Op_Escan 55 +#define Op_Esusp 56 +#define Op_Field 57 +#define Op_Goto 58 +#define Op_Init 59 +#define Op_Int 60 +#define Op_Invoke 61 +#define Op_Keywd 62 +#define Op_Limit 63 +#define Op_Line 64 +#define Op_Llist 65 +#define Op_Lsusp 66 +#define Op_Mark 67 +#define Op_Pfail 68 +#define Op_Pnull 69 +#define Op_Pop 70 +#define Op_Pret 71 +#define Op_Psusp 72 +#define Op_Push1 73 +#define Op_Pushn1 74 +#define Op_Real 75 +#define Op_Sdup 76 +#define Op_Str 77 +#define Op_Unmark 78 +#define Op_Var 80 +#define Op_Arg 81 +#define Op_Static 82 +#define Op_Local 83 +#define Op_Global 84 +#define Op_Mark0 85 +#define Op_Quit 86 +#define Op_FQuit 87 +#define Op_Tally 88 +#define Op_Apply 89 + +/* + * "Absolute" address operations. These codes are inserted in the + * icode at run-time by the interpreter to overwrite operations + * that initially compute a location relative to locations not known until + * the icode file is loaded. + */ +#define Op_Acset 90 +#define Op_Areal 91 +#define Op_Astr 92 +#define Op_Aglobal 93 +#define Op_Astatic 94 +#define Op_Agoto 95 +#define Op_Amark 96 + +#define Op_Noop 98 + +#define Op_Colm 108 /* column number */ + +/* + * Declarations and such -- used by the linker but not the run-time system. + */ + +#define Op_Proc 101 +#define Op_Declend 102 +#define Op_End 103 +#define Op_Link 104 +#define Op_Version 105 +#define Op_Con 106 +#define Op_Filen 107 + +/* + * Global symbol table declarations. + */ +#define Op_Record 105 +#define Op_Impl 106 +#define Op_Error 107 +#define Op_Trace 108 +#define Op_Lab 109 +#define Op_Invocable 110 diff --git a/src/h/parserr.h b/src/h/parserr.h new file mode 100644 index 0000000..e8c92d4 --- /dev/null +++ b/src/h/parserr.h @@ -0,0 +1,177 @@ +/* + * parserr.h -- table of parser error messages. + * + * Each entry maps a syntax error from a particular Yacc state into a + * descriptive message. This file needs to be updated whenever the + * grammar is changed. + */ + +static struct errmsg { + int e_state; /* parser state number */ + char *e_mesg; /* message text */ + } errtab[] = { + + 0, "invalid declaration", + 1, "end of file expected", + 2, "invalid declaration", + 12, "missing semicolon", + 14, "link list expected", + 15, "invocable list expected", + 17, "invalid declaration", + 18, "missing record name", + 21, "invalid global declaration", + 30, "missing procedure name", + 32, "missing field list in record declaration", + 34, "missing end", + 35, "missing semicolon or operator", + 50, "invalid argument for unary operator", + 51, "invalid argument for unary operator", + 52, "invalid argument for unary operator", + 53, "invalid argument for unary operator", + 54, "invalid argument for unary operator", + 55, "invalid argument for unary operator", + 56, "invalid argument for unary operator", + 57, "invalid argument for unary operator", + 58, "invalid argument for unary operator", + 59, "invalid argument for unary operator", + 60, "invalid argument for unary operator", + 61, "invalid argument for unary operator", + 62, "invalid argument for unary operator", + 63, "invalid argument for unary operator", + 64, "invalid argument for unary operator", + 65, "invalid argument for unary operator", + 66, "invalid argument for unary operator", + 67, "invalid argument for unary operator", + 68, "invalid argument for unary operator", + 69, "invalid argument for unary operator", + 70, "invalid argument for unary operator", + 71, "invalid argument for unary operator", + 72, "invalid argument for unary operator", + 73, "invalid argument for unary operator", + 83, "invalid create expression", + 86, "invalid break expression", + 87, "invalid expression list", + 88, "invalid compound expression", + 89, "invalid expression list", + 90, "invalid keyword construction", + 96, "invalid return expression", + 97, "invalid suspend expression", + 98, "invalid if control expression", + 99, "invalid case control expression", + 100, "invalid while control expression", + 101, "invalid until control expression", + 102, "invalid every control expression", + 103, "invalid repeat expression", + 106, "missing link file name", + 107, "missing operation name", + 108, "missing number of arguments", + 109, "missing parameter list in procedure declaration", + 111, "invalid procedure body", + 112, "invalid local declaration", + 113, "invalid initial expression", + 117, "invalid expression", + 118, "invalid argument", + 119, "invalid argument", + 120, "invalid argument in assignment", + 121, "invalid argument in assignment", + 122, "invalid argument in assignment", + 123, "invalid argument in assignment", + 124, "invalid argument in augmented assignment", + 125, "invalid argument in augmented assignment", + 126, "invalid argument in augmented assignment", + 127, "invalid argument in augmented assignment", + 128, "invalid argument in augmented assignment", + 129, "invalid argument in augmented assignment", + 130, "invalid argument in augmented assignment", + 131, "invalid argument in augmented assignment", + 132, "invalid argument in augmented assignment", + 133, "invalid argument in augmented assignment", + 134, "invalid argument in augmented assignment", + 135, "invalid argument in augmented assignment", + 136, "invalid argument in augmented assignment", + 137, "invalid argument in augmented assignment", + 138, "invalid argument in augmented assignment", + 139, "invalid argument in augmented assignment", + 140, "invalid argument in augmented assignment", + 141, "invalid argument in augmented assignment", + 142, "invalid argument in augmented assignment", + 143, "invalid argument in augmented assignment", + 144, "invalid argument in augmented assignment", + 145, "invalid argument in augmented assignment", + 146, "invalid argument in augmented assignment", + 147, "invalid argument in augmented assignment", + 148, "invalid argument in augmented assignment", + 149, "invalid argument in augmented assignment", + 150, "invalid argument in augmented assignment", + 151, "invalid argument in augmented assignment", + 152, "invalid to clause", + 153, "invalid argument in alternation", + 154, "invalid argument", + 155, "invalid argument", + 156, "invalid argument", + 157, "invalid argument", + 158, "invalid argument", + 159, "invalid argument", + 160, "invalid argument", + 161, "invalid argument", + 162, "invalid argument", + 163, "invalid argument", + 164, "invalid argument", + 165, "invalid argument", + 166, "invalid argument", + 167, "invalid argument", + 168, "invalid argument", + 169, "invalid argument", + 170, "invalid argument", + 171, "invalid argument", + 172, "invalid argument", + 173, "invalid argument", + 174, "invalid argument", + 175, "invalid argument", + 176, "invalid argument", + 177, "invalid argument", + 178, "invalid argument", + 179, "invalid argument", + 180, "invalid argument", + 181, "invalid argument", + 182, "invalid subscript", + 183, "invalid pdco list", + 184, "invalid expression list", + 185, "invalid field name", + 212, "missing right parenthesis", + 214, "missing right brace", + 216, "missing right bracket", + 222, "missing then", + 223, "missing of", + 228, "missing identifier", + 233, "missing right parenthesis", + 235, "missing end", + 236, "invalid declaration", + 237, "missing semicolon or operator", + 303, "missing right bracket", + 306, "missing right brace", + 308, "missing right parenthesis", + 311, "invalid expression list", + 313, "invalid expression", + 315, "invalid do clause", + 316, "invalid then clause", + 317, "missing left brace", + 318, "invalid do clause", + 319, "invalid do clause", + 320, "invalid do clause", + 322, "invalid parameter list", + 328, "invalid by clause", + 330, "invalid section", + 335, "invalid pdco list", + 341, "invalid case clause", + 346, "missing right bracket", + 348, "missing right bracket or ampersand", + 350, "invalid else clause", + 351, "missing right brace or semicolon", + 353, "missing colon", + 354, "missing colon or ampersand", + 359, "invalid case clause", + 360, "invalid default clause", + 361, "invalid case clause", + -1, "syntax error" + }; diff --git a/src/h/rexterns.h b/src/h/rexterns.h new file mode 100644 index 0000000..804424c --- /dev/null +++ b/src/h/rexterns.h @@ -0,0 +1,223 @@ +/* + * External declarations for the run-time system. + */ + +/* + * External declarations common to the compiler and interpreter. + */ + +extern struct b_proc *op_tbl; /* operators available for string invocation */ +extern int op_tbl_sz; /* number of operators in op_tbl */ +extern int debug_info; /* flag: debugging information is available */ +extern int err_conv; /* flag: error conversion is supported */ +extern int dodump; /* termination dump */ +extern int line_info; /* flag: line information is available */ +extern char *file_name; /* source file for current execution point */ +extern int line_num; /* line number for current execution point */ + +extern unsigned char allchars[];/* array for making one-character strings */ +extern char *blkname[]; /* print names for block types. */ +extern char *currend; /* current end of memory region */ +extern dptr *quallist; /* start of qualifier list */ +extern int bsizes[]; /* sizes of blocks */ +extern int firstd[]; /* offset (words) of first descrip. */ +extern uword segsize[]; /* size of hash bucket segment */ +extern int k_level; /* value of &level */ + +extern struct b_coexpr *stklist;/* base of co-expression stack list */ +extern struct b_cset blankcs; /* ' ' */ +extern struct b_cset lparcs; /* '(' */ +extern struct b_cset rparcs; /* ')' */ +extern struct b_cset fullcs; /* cset containing all characters */ +extern struct descrip blank; /* blank */ +extern struct descrip emptystr; /* empty string */ + +extern struct descrip kywd_dmp; /* descriptor for &dump */ +extern struct descrip nullptr; /* descriptor with null block pointer */ +extern struct descrip lcase; /* lowercase string */ +extern struct descrip letr; /* letter "r" */ +extern struct descrip maps2; /* second argument to map() */ +extern struct descrip maps3; /* third argument to map() */ +extern struct descrip nulldesc; /* null value */ +extern struct descrip onedesc; /* one */ +extern struct descrip ucase; /* uppercase string */ +extern struct descrip zerodesc; /* zero */ + +extern word mstksize; /* size of main stack in words */ +extern word stksize; /* size of co-expression stacks in words */ +extern word qualsize; /* size of string qualifier list */ +extern word memcushion; /* memory region cushion factor */ +extern word memgrowth; /* memory region growth factor */ +extern uword stattotal; /* cumulative total of all static allocations */ + /* N.B. not currently set */ + +extern struct tend_desc *tend; /* chain of tended descriptors */ + +/* + * Externals that are conditional on features. + */ +#ifdef FncTrace + extern struct descrip kywd_ftrc; /* descriptor for &ftrace */ +#endif /* FncTrace */ + +#ifdef Polling + extern int pollctr; +#endif /* Polling */ + +#ifdef EventMon + extern char typech[]; + extern word oldsum; + extern struct descrip csetdesc; /* cset descriptor */ + extern struct descrip eventdesc; /* event descriptor */ + extern struct b_iproc mt_llist; + extern struct descrip rzerodesc; /* real descriptor */ + extern struct b_real realzero; /* real zero block */ +#endif /* EventMon */ + +/* + * Externals conditional on multithreading. + */ + extern struct region rootstring; + extern struct region rootblock; +#ifndef MultiThread + extern dptr glbl_argp; /* argument pointer */ + extern struct region *curstring; + extern struct region *curblock; + extern struct descrip k_current; /* ¤t */ + extern char *k_errortext; /* value of &errortext */ + extern int have_errval; /* &errorvalue has a legal value */ + extern int k_errornumber; /* value of &errornumber */ + extern int t_errornumber; /* tentative k_errornumber value */ + extern int t_have_val; /* tentative have_errval flag */ + extern struct b_file k_errout; /* value of &errout */ + extern struct b_file k_input; /* value of &input */ + extern struct b_file k_output; /* value of &output */ + extern struct descrip k_errorvalue; /* value of &errorvalue */ + extern struct descrip kywd_err; /* &error */ + extern struct descrip kywd_pos; /* descriptor for &pos */ + extern struct descrip kywd_prog; /* descriptor for &prog */ + extern struct descrip kywd_ran; /* descriptor for &random */ + extern struct descrip k_subject; /* &subject */ + extern struct descrip kywd_trc; /* descriptor for &trace */ + extern struct descrip k_eventcode; /* &eventcode */ + extern struct descrip k_eventsource; /* &eventsource */ + extern struct descrip k_eventvalue; /* &eventvalue */ + extern struct descrip k_main; /* value of &main */ + extern struct descrip t_errorvalue; /* tentative k_errorvalue value */ + extern uword blktotal; /* cumul total of all block allocs */ + extern uword strtotal; /* cumul total of all string allocs */ + extern word coll_tot; /* total number of collections */ + extern word coll_stat; /* collections from static reqests */ + extern word coll_str; /* collections from string requests */ + extern word coll_blk; /* collections from block requests */ + extern dptr globals; /* start of global variables */ + extern dptr eglobals; /* end of global variables */ + extern dptr gnames; /* start of global variable names */ + extern dptr egnames; /* end of global variable names */ + extern dptr estatics; /* end of static variables */ + extern int n_globals; /* number of global variables */ + extern int n_statics; /* number of static variables */ + extern struct b_coexpr *mainhead; /* &main */ +#endif /* MultiThread */ + +/* + * Externals that differ between compiler and interpreter. + */ +#if !COMPILER + /* + * External declarations for the interpreter. + */ + + extern int ixinited; /* iconx has initialized */ + extern inst ipc; /* interpreter program counter */ + extern int ilevel; /* interpreter level */ + extern int ntended; /* number of active tended descriptors*/ + extern struct b_cset k_ascii; /* value of &ascii */ + extern struct b_cset k_cset; /* value of &cset */ + extern struct b_cset k_digits; /* value of &lcase */ + extern struct b_cset k_lcase; /* value of &lcase */ + extern struct b_cset k_letters; /* value of &letters */ + extern struct b_cset k_ucase; /* value of &ucase */ + extern struct descrip tended[]; /* tended descriptors */ + extern struct ef_marker *efp; /* expression frame pointer */ + extern struct gf_marker *gfp; /* generator frame pointer */ + extern struct pf_marker *pfp; /* procedure frame pointer */ + extern word *sp; /* interpreter stack pointer */ + extern word *stack; /* interpreter stack base */ + extern word *stackend; /* end of evaluation stack */ + + extern struct pstrnm pntab[]; + extern int pnsize; + + #ifdef MultiThread + extern struct progstate *curpstate; + extern struct progstate rootpstate; + extern int noMTevents; /* no MT events during GC */ + #else /* MultiThread */ + extern char *code; /* start of icode */ + extern char *ecode; /* end of icode */ + extern dptr statics; /* start of static variables */ + extern char *strcons; /* start of the string constants */ + extern dptr fnames; /* field names */ + extern dptr efnames; /* end of field names */ + extern word *records; + extern int *ftabp; /* field table pointer */ + #ifdef FieldTableCompression + extern word ftabwidth, foffwidth; + extern unsigned char *ftabcp; + extern short *ftabsp; + #endif /* FieldTableCompression */ + extern dptr xargp; + extern word xnargs; + + extern word lastop; + #endif /* MultiThread */ + +#else /* COMPILER */ + + extern struct descrip statics[]; /* array of static variables */ + extern struct b_proc *builtins[]; /* pointers to builtin functions */ + extern int noerrbuf; /* error buffering */ + extern struct p_frame *pfp; /* procedure frame pointer */ + extern struct descrip trashcan; /* dummy descriptor, never read */ + extern int largeints; /* flag: large integers supported */ + +#endif /* COMPILER */ + +/* + * graphics + */ +#ifdef Graphics + + extern stringint attribs[], drawops[]; + extern wbp wbndngs; + extern wcp wcntxts; + extern wsp wstates; + extern int GraphicsLeft, GraphicsUp, GraphicsRight, GraphicsDown; + extern int GraphicsHome, GraphicsPrior, GraphicsNext, GraphicsEnd; + extern int win_highwater, canvas_serial, context_serial; + extern clock_t starttime; /* start time in milliseconds */ + + #ifndef MultiThread + extern struct descrip kywd_xwin[]; + extern struct descrip lastEventWin; + extern int lastEvFWidth, lastEvLeading, lastEvAscent; + extern struct descrip amperCol; + extern struct descrip amperRow; + extern struct descrip amperX; + extern struct descrip amperY; + extern struct descrip amperInterval; + extern uword xmod_control, xmod_shift, xmod_meta; + #endif /* MultiThread */ + + #ifdef XWindows + extern struct _wdisplay * wdsplys; + extern stringint cursorsyms[]; + #endif /* XWindows */ + + #ifdef WinGraphics + extern HINSTANCE mswinInstance; + extern int ncmdShow; + #endif /* WinGraphics */ + +#endif /* Graphics */ diff --git a/src/h/rmacros.h b/src/h/rmacros.h new file mode 100644 index 0000000..cce26dd --- /dev/null +++ b/src/h/rmacros.h @@ -0,0 +1,687 @@ +/* + * Definitions for macros and manifest constants used in the compiler + * interpreter. + */ + +/* + * Definitions common to the compiler and interpreter. + */ + +/* + * Constants that are not likely to vary between implementations. + */ + +#define BitOffMask (IntBits-1) +#define CsetSize (256/IntBits) /* number of ints to hold 256 cset + * bits. Use (256/IntBits)+1 if + * 256 % IntBits != 0 */ +#define MinListSlots 8 /* number of elements in an expansion + * list element block */ + +#define MaxCvtLen 257 /* largest string in conversions; the extra + * one is for a terminating null */ +#define MaxReadStr 512 /* largest string to read() in one piece */ +#define MaxIn 32767 /* largest number of bytes to read() at once */ +#define RandA 1103515245 /* random seed multiplier */ +#define RandC 453816694 /* random seed additive constant */ +#define RanScale 4.65661286e-10 /* random scale factor = 1/(2^31-1) */ + +#define Pi 3.14159265358979323846264338327950288419716939937511 + +/* + * File status flags in status field of file blocks. + */ +#define Fs_Read 01 /* read access */ +#define Fs_Write 02 /* write access */ +#define Fs_Create 04 /* file created on open */ +#define Fs_Append 010 /* append mode */ +#define Fs_Pipe 020 /* reading/writing on a pipe */ +#define Fs_Untrans 01000 /* untranslated mode file */ +#define Fs_Directory 02000 /* reading a directory */ +#define Fs_Reading 0100 /* last file operation was read */ +#define Fs_Writing 0200 /* last file operation was write */ + +#ifdef Graphics + #define Fs_Window 0400 /* reading/writing on a window */ + + #define XKey_Window 0 + #define XKey_Fg 1 + + #ifndef SHORT + #define SHORT int + #endif /* SHORT */ + #ifndef LONG + #define LONG int + #endif /* LONG */ + + /* + * Perform a "C" return, not processed by RTT + */ + #define VanquishReturn(s) return s; +#endif /* Graphics */ + +/* + * Codes returned by runtime support routines. + * Note, some conversion routines also return type codes. Other routines may + * return positive values other than return codes. sort() places restrictions + * on Less, Equal, and Greater. + */ + +#define Less -1 +#define Equal 0 +#define Greater 1 + +#define CvtFail -2 +#define Cvt -3 +#define NoCvt -4 +#define Failed -5 +#define Defaulted -6 +#define Succeeded -7 +#define Error -8 + +#define GlobalName 0 +#define StaticName 1 +#define ParamName 2 +#define LocalName 3 + +/* + * Pointer to block. + */ +#define BlkLoc(d) ((d).vword.bptr) + +/* + * Check for null-valued descriptor. + */ +#define ChkNull(d) ((d).dword==D_Null) + +/* + * Check for equivalent descriptors. + */ +#define EqlDesc(d1,d2) ((d1).dword == (d2).dword && BlkLoc(d1) == BlkLoc(d2)) + +/* + * Integer value. + */ +#define IntVal(d) ((d).vword.integr) + +/* + * Offset from top of block to value of variable. + */ +#define Offset(d) ((d).dword & OffsetMask) + +/* + * Check for pointer. + */ +#define Pointer(d) ((d).dword & F_Ptr) + +/* + * Check for qualifier. + */ +#define Qual(d) (!((d).dword & F_Nqual)) + +/* + * Length of string. + */ +#define StrLen(q) ((q).dword) + +/* + * Location of first character of string. + */ +#define StrLoc(q) ((q).vword.sptr) + +/* + * Assign a C string to a descriptor. Assume it is reasonable to use the + * descriptor expression more than once, but not the string expression. + */ +#define AsgnCStr(d,s) (StrLoc(d) = (s), StrLen(d) = strlen(StrLoc(d))) + +/* + * Type of descriptor. + */ +#define Type(d) (int)((d).dword & TypeMask) + +/* + * Check for variable. + */ +#define Var(d) ((d).dword & F_Var) + +/* + * Location of the value of a variable. + */ +#define VarLoc(d) ((d).vword.descptr) + +/* + * Important note: The code that follows is not strictly legal C. + * It tests to see if pointer p2 is between p1 and p3. This may + * involve the comparison of pointers in different arrays, which + * is not well-defined. The casts of these pointers to unsigned "words" + * (longs or ints, depending) works with all C compilers and architectures + * on which Icon has been implemented. However, it is possible it will + * not work on some system. If it doesn't, there may be a "false + * positive" test, which is likely to cause a memory violation or a + * loop. It is not practical to implement Icon on a system on which this + * happens. + */ + +#define InRange(p1,p2,p3) ((uword)(p2) >= (uword)(p1) && (uword)(p2) < (uword)(p3)) + +/* + * Get floating-point number from real block. + */ +#ifdef Double + #define GetReal(dp,res) *((struct size_dbl *)&(res)) =\ + *((struct size_dbl *)&(BlkLoc(*dp)->realblk.realval)) +#else /* Double */ + #define GetReal(dp,res) res = BlkLoc(*dp)->realblk.realval +#endif /* Double */ + +/* + * Absolute value, maximum, and minimum. + * N.B. UNSAFE MACROS: may evaluate arguments multiple times. + */ +#define Abs(x) (((x) < 0) ? (-(x)) : (x)) +#define Max(x,y) ((x)>(y)?(x):(y)) +#define Min(x,y) ((x)<(y)?(x):(y)) + +/* + * Number of elements of a C array, and element size. + */ +#define ElemCount(a) (sizeof(a)/sizeof(a[0])) +#define ElemSize(a) (sizeof(a[0])) + +/* + * Construct an integer descriptor. + */ +#define MakeInt(i,dp) do { \ + (dp)->dword = D_Integer; \ + IntVal(*dp) = (word)(i); \ + } while (0) + +/* + * Construct a string descriptor. + */ +#define MakeStr(s,len,dp) do { \ + StrLoc(*dp) = (s); \ + StrLen(*dp) = (len); \ + } while (0) + +/* + * Offset in word of cset bit. + */ +#define CsetOff(b) ((b) & BitOffMask) + +/* + * Set bit b in cset c. + */ +#define Setb(b,c) (*CsetPtr(b,c) |= (01 << CsetOff(b))) + +/* + * Test bit b in cset c. + */ +#define Testb(b,c) ((*CsetPtr(b,c) >> CsetOff(b)) & 01) + +/* + * Check whether a set or table needs resizing. + */ +#define SP(p) ((struct b_set *)p) +#define TooCrowded(p) \ + ((SP(p)->size > MaxHLoad*(SP(p)->mask+1)) && (SP(p)->hdir[HSegs-1] == NULL)) +#define TooSparse(p) \ + ((SP(p)->hdir[1] != NULL) && (SP(p)->size < MinHLoad*(SP(p)->mask+1))) + +/* + * Definitions and declarations used for storage management. + */ +#define F_Mark 0100000 /* bit for marking blocks */ + +/* + * Argument values for the built-in Icon user function "collect()". + */ +#define Static 1 /* collection is for static region */ +#define Strings 2 /* collection is for strings */ +#define Blocks 3 /* collection is for blocks */ + +/* + * Get type of block pointed at by x. + */ +#define BlkType(x) (*(word *)x) + +/* + * BlkSize(x) takes the block pointed to by x and if the size of + * the block as indicated by bsizes[] is nonzero it returns the + * indicated size; otherwise it returns the second word in the + * block contains the size. + */ +#define BlkSize(x) (bsizes[*(word *)x & ~F_Mark] ? \ + bsizes[*(word *)x & ~F_Mark] : *((word *)x + 1)) + +/* + * Here are the events we support (in addition to keyboard characters) + */ +#define MOUSELEFT (-1) +#define MOUSEMID (-2) +#define MOUSERIGHT (-3) +#define MOUSELEFTUP (-4) +#define MOUSEMIDUP (-5) +#define MOUSERIGHTUP (-6) +#define MOUSELEFTDRAG (-7) +#define MOUSEMIDDRAG (-8) +#define MOUSERIGHTDRAG (-9) +#define RESIZED (-10) +#define LASTEVENTCODE RESIZED + +/* + * Type codes (descriptors and blocks). + */ +#define T_String -1 /* string -- for reference; not used */ +#define T_Null 0 /* null value */ +#define T_Integer 1 /* integer */ + +#ifdef LargeInts + #define T_Lrgint 2 /* long integer */ +#endif /* LargeInts */ + +#define T_Real 3 /* real number */ +#define T_Cset 4 /* cset */ +#define T_File 5 /* file */ +#define T_Proc 6 /* procedure */ +#define T_Record 7 /* record */ +#define T_List 8 /* list header */ +#define T_Lelem 9 /* list element */ +#define T_Set 10 /* set header */ +#define T_Selem 11 /* set element */ +#define T_Table 12 /* table header */ +#define T_Telem 13 /* table element */ +#define T_Tvtbl 14 /* table element trapped variable */ +#define T_Slots 15 /* set/table hash slots */ +#define T_Tvsubs 16 /* substring trapped variable */ +#define T_Refresh 17 /* refresh block */ +#define T_Coexpr 18 /* co-expression */ +#define T_External 19 /* external block */ +#define T_Kywdint 20 /* integer keyword */ +#define T_Kywdpos 21 /* keyword &pos */ +#define T_Kywdsubj 22 /* keyword &subject */ +#define T_Kywdwin 23 /* keyword &window */ +#define T_Kywdstr 24 /* string keyword */ +#define T_Kywdevent 25 /* keyword &eventsource, etc. */ + +#define MaxType 26 /* maximum type number */ + +/* + * Definitions for keywords. + */ + +#define k_pos kywd_pos.vword.integr /* value of &pos */ +#define k_random kywd_ran.vword.integr /* value of &random */ +#define k_trace kywd_trc.vword.integr /* value of &trace */ +#define k_dump kywd_dmp.vword.integr /* value of &dump */ + +#ifdef FncTrace + #define k_ftrace kywd_ftrc.vword.integr /* value of &ftrace */ +#endif /* FncTrace */ + +/* + * Descriptor types and flags. + */ + +#define D_Null (T_Null | D_Typecode) +#define D_Integer (T_Integer | D_Typecode) + +#ifdef LargeInts + #define D_Lrgint (T_Lrgint | D_Typecode | F_Ptr) +#endif /* LargeInts */ + +#define D_Real (T_Real | D_Typecode | F_Ptr) +#define D_Cset (T_Cset | D_Typecode | F_Ptr) +#define D_File (T_File | D_Typecode | F_Ptr) +#define D_Proc (T_Proc | D_Typecode | F_Ptr) +#define D_List (T_List | D_Typecode | F_Ptr) +#define D_Lelem (T_Lelem | D_Typecode | F_Ptr) +#define D_Table (T_Table | D_Typecode | F_Ptr) +#define D_Telem (T_Telem | D_Typecode | F_Ptr) +#define D_Set (T_Set | D_Typecode | F_Ptr) +#define D_Selem (T_Selem | D_Typecode | F_Ptr) +#define D_Record (T_Record | D_Typecode | F_Ptr) +#define D_Tvsubs (T_Tvsubs | D_Typecode | F_Ptr | F_Var) +#define D_Tvtbl (T_Tvtbl | D_Typecode | F_Ptr | F_Var) +#define D_Kywdint (T_Kywdint | D_Typecode | F_Ptr | F_Var) +#define D_Kywdpos (T_Kywdpos | D_Typecode | F_Ptr | F_Var) +#define D_Kywdsubj (T_Kywdsubj | D_Typecode | F_Ptr | F_Var) +#define D_Refresh (T_Refresh | D_Typecode | F_Ptr) +#define D_Coexpr (T_Coexpr | D_Typecode | F_Ptr) +#define D_External (T_External | D_Typecode | F_Ptr) +#define D_Slots (T_Slots | D_Typecode | F_Ptr) +#define D_Kywdwin (T_Kywdwin | D_Typecode | F_Ptr | F_Var) +#define D_Kywdstr (T_Kywdstr | D_Typecode | F_Ptr | F_Var) +#define D_Kywdevent (T_Kywdevent| D_Typecode | F_Ptr | F_Var) + +#define D_Var (F_Var | F_Nqual | F_Ptr) +#define D_Typecode (F_Nqual | F_Typecode) + +#define TypeMask 63 /* type mask */ +#define OffsetMask (~(D_Var)) /* offset mask for variables */ + +/* + * "In place" dereferencing. + */ +#define Deref(d) if (Var(d)) deref(&d, &d) + +/* + * Construct a substring trapped variable. + */ +#define SubStr(dest,var,len,pos)\ + if ((var)->dword == D_Tvsubs)\ + (dest)->vword.bptr = (union block *)alcsubs(len, (pos) +\ + BlkLoc(*(var))->tvsubs.sspos - 1, &BlkLoc(*(var))->tvsubs.ssvar);\ + else\ + (dest)->vword.bptr = (union block *)alcsubs(len, pos, (var));\ + (dest)->dword = D_Tvsubs; + +/* + * Find debug struct in procedure frame, assuming debugging is enabled. + * Note that there is always one descriptor in array even if it is not + * being used. + */ +#define PFDebug(pf) ((struct debug *)((char *)(pf).tend.d +\ + sizeof(struct descrip) * ((pf).tend.num ? (pf).tend.num : 1))) + +/* + * Macro for initialized procedure block. + */ +#define B_IProc(n) struct {word title; word blksize; int (*ccode)();\ + word nparam; word ndynam; word nstatic; word fstatic;\ + struct sdescrip quals[n];} + +#define ssize (curstring->size) +#define strbase (curstring->base) +#define strend (curstring->end) +#define strfree (curstring->free) + +#define abrsize (curblock->size) +#define blkbase (curblock->base) +#define blkend (curblock->end) +#define blkfree (curblock->free) + +#if COMPILER + + #ifdef Graphics + #define Poll() if (!pollctr--) pollctr = pollevent() + #else /* Graphics */ + #define Poll() + #endif /* Graphics */ + +#else /* COMPILER */ + + /* + * Definitions for the interpreter. + */ + + /* + * Codes returned by invoke to indicate action. + */ + #define I_Builtin 201 /* A built-in routine is to be invoked */ + #define I_Fail 202 /* goal-directed evaluation failed */ + #define I_Continue 203 /* Continue execution in the interp loop */ + #define I_Vararg 204 /* A function with a variable number of args */ + + /* + * Generator types. + */ + #define G_Csusp 1 + #define G_Esusp 2 + #define G_Psusp 3 + #define G_Fsusp 4 + #define G_Osusp 5 + + /* + * Evaluation stack overflow margin + */ + #define PerilDelta 100 + + /* + * Macros for pushing values on the interpreter stack. + */ + + /* + * Push descriptor. + */ + #define PushDescSP(SP,d) {*++SP=((d).dword); SP++; *SP =((d).vword.integr);} + + /* + * Push null-valued descriptor. + */ + #define PushNullSP(SP) {*++SP = D_Null; SP++; *SP = 0;} + + /* + * Push word. + */ + #define PushValSP(SP,v) {*++SP = (word)(v);} + + /* + * Shorter Versions of the Push*SP macros that assume sp points to the top + * of the stack. + */ + #define PushDesc(d) PushDescSP(sp,d) + #define PushNull PushNullSP(sp) + #define PushVal(x) PushValSP(sp,x) + #define PushAVal(x) PushValSP(sp,x) + + /* + * Macros related to function and operator definition. + */ + + /* + * Procedure block for a function. + */ + + #define FncBlock(f,nargs,deref) \ + struct b_iproc Cat(B,f) = {\ + T_Proc,\ + Vsizeof(struct b_proc),\ + Cat(Z,f),\ + nargs,\ + -1,\ + deref, 0,\ + {sizeof(Lit(f))-1,Lit(f)}}; + + /* + * Procedure block for an operator. + */ + #define OpBlock(f,nargs,sname,xtrargs)\ + struct b_iproc Cat(B,f) = {\ + T_Proc,\ + Vsizeof(struct b_proc),\ + Cat(O,f),\ + nargs,\ + -1,\ + xtrargs,\ + 0,\ + {sizeof(sname)-1,sname}}; + + /* + * Operator declaration. + */ + #define OpDcl(nm,n,pn) OpBlock(nm,n,pn,0) Cat(O,nm)(cargp) register dptr cargp; + + /* + * Operator declaration with extra working argument. + */ + #define OpDclE(nm,n,pn) OpBlock(nm,-n,pn,0) Cat(O,nm)(cargp) register dptr cargp; + + /* + * Agent routine declaration. + */ + #define AgtDcl(nm) Cat(A,nm)(cargp) register dptr cargp; + + /* + * Macros to access Icon arguments in C functions. + */ + + /* + * n-th argument. + */ + #define Arg(n) (cargp[n]) + + /* + * Type field of n-th argument. + */ + #define ArgType(n) (cargp[n].dword) + + /* + * Value field of n-th argument. + */ + #define ArgVal(n) (cargp[n].vword.integr) + + /* + * Specific arguments. + */ + #define Arg0 (cargp[0]) + #define Arg1 (cargp[1]) + #define Arg2 (cargp[2]) + #define Arg3 (cargp[3]) + #define Arg4 (cargp[4]) + #define Arg5 (cargp[5]) + #define Arg6 (cargp[6]) + #define Arg7 (cargp[7]) + #define Arg8 (cargp[8]) + + /* + * Miscellaneous macro definitions. + */ + + #ifdef MultiThread + #define glbl_argp (curpstate->Glbl_argp) + #define kywd_err (curpstate->Kywd_err) + #define kywd_pos (curpstate->Kywd_pos) + #define kywd_prog (curpstate->Kywd_prog) + #define kywd_ran (curpstate->Kywd_ran) + #define k_eventcode (curpstate->eventcode) + #define k_eventsource (curpstate->eventsource) + #define k_eventvalue (curpstate->eventval) + #define k_subject (curpstate->ksub) + #define kywd_trc (curpstate->Kywd_trc) + #define mainhead (curpstate->Mainhead) + #define code (curpstate->Code) + #define ecode (curpstate->Ecode) + #define records (curpstate->Records) + #define ftabp (curpstate->Ftabp) + #ifdef FieldTableCompression + #define ftabwidth (curpstate->Ftabwidth) + #define foffwidth (curpstate->Foffwidth) + #define ftabcp (curpstate->Ftabcp) + #define ftabsp (curpstate->Ftabsp) + #define focp (curpstate->Focp) + #define fosp (curpstate->Fosp) + #define fo (curpstate->Fo) + #define bm (curpstate->Bm) + #endif /* FieldTableCompression */ + #define fnames (curpstate->Fnames) + #define efnames (curpstate->Efnames) + #define globals (curpstate->Globals) + #define eglobals (curpstate->Eglobals) + #define gnames (curpstate->Gnames) + #define egnames (curpstate->Egnames) + #define statics (curpstate->Statics) + #define estatics (curpstate->Estatics) + #define n_globals (curpstate->NGlobals) + #define n_statics (curpstate->NStatics) + #define strcons (curpstate->Strcons) + #define filenms (curpstate->Filenms) + #define efilenms (curpstate->Efilenms) + #define ilines (curpstate->Ilines) + #define elines (curpstate->Elines) + #define current_line_ptr (curpstate->Current_line_ptr) + + #ifdef Graphics + #define amperX (curpstate->AmperX) + #define amperY (curpstate->AmperY) + #define amperRow (curpstate->AmperRow) + #define amperCol (curpstate->AmperCol) + #define amperInterval (curpstate->AmperInterval) + #define lastEventWin (curpstate->LastEventWin) + #define lastEvFWidth (curpstate->LastEvFWidth) + #define lastEvLeading (curpstate->LastEvLeading) + #define lastEvAscent (curpstate->LastEvAscent) + #define kywd_xwin (curpstate->Kywd_xwin) + #define xmod_control (curpstate->Xmod_Control) + #define xmod_shift (curpstate->Xmod_Shift) + #define xmod_meta (curpstate->Xmod_Meta) + #endif /* Graphics */ + + #ifdef EventMon + #define linenum (curpstate->Linenum) + #define column (curpstate->Column) + #define lastline (curpstate->Lastline) + #define lastcol (curpstate->Lastcol) + #endif /* EventMon */ + + #define coexp_ser (curpstate->Coexp_ser) + #define list_ser (curpstate->List_ser) + #define set_ser (curpstate->Set_ser) + #define table_ser (curpstate->Table_ser) + + #define curstring (curpstate->stringregion) + #define curblock (curpstate->blockregion) + #define strtotal (curpstate->stringtotal) + #define blktotal (curpstate->blocktotal) + + #define coll_tot (curpstate->colltot) + #define coll_stat (curpstate->collstat) + #define coll_str (curpstate->collstr) + #define coll_blk (curpstate->collblk) + + #define lastop (curpstate->Lastop) + #define lastopnd (curpstate->Lastopnd) + + #define xargp (curpstate->Xargp) + #define xnargs (curpstate->Xnargs) + + #define k_current (curpstate->K_current) + #define k_errornumber (curpstate->K_errornumber) + #define k_errortext (curpstate->K_errortext) + #define k_errorvalue (curpstate->K_errorvalue) + #define have_errval (curpstate->Have_errval) + #define t_errornumber (curpstate->T_errornumber) + #define t_have_val (curpstate->T_have_val) + #define t_errorvalue (curpstate->T_errorvalue) + + #define k_main (curpstate->K_main) + #define k_errout (curpstate->K_errout) + #define k_input (curpstate->K_input) + #define k_output (curpstate->K_output) + + #define ENTERPSTATE(p) if (((p)!=NULL)) { curpstate = (p); } + #endif /* MultiThread */ + +#endif /* COMPILER */ + +/* + * Constants controlling expression evaluation. + */ +#if COMPILER + #define A_Resume -1 /* expression failed: resume a generator */ + #define A_Continue -2 /* expression returned: continue execution */ + #define A_FallThru -3 /* body function: fell through end of code */ + #define A_Coact 1 /* co-expression activation */ + #define A_Coret 2 /* co-expression return */ + #define A_Cofail 3 /* co-expression failure */ +#else /* COMPILER */ + #define A_Resume 1 /* routine failed */ + #define A_Pret_uw 2 /* interp unwind for Op_Pret */ + #define A_Unmark_uw 3 /* interp unwind for Op_Unmark */ + #define A_Pfail_uw 4 /* interp unwind for Op_Pfail */ + #define A_Lsusp_uw 5 /* interp unwind for Op_Lsusp */ + #define A_Eret_uw 6 /* interp unwind for Op_Eret */ + #define A_Continue 7 /* routine returned */ + #define A_Coact 8 /* co-expression activated */ + #define A_Coret 9 /* co-expression returned */ + #define A_Cofail 10 /* co-expression failed */ + #ifdef MultiThread + #define A_MTEvent 11 /* multithread event */ + #endif /* MultiThread */ +#endif /* COMPILER */ + +/* + * Address of word containing cset bit b (c is a struct descrip of type Cset). + */ +#define CsetPtr(b,c) (BlkLoc(c)->cset.bits + (((b)&0377) >> LogIntBits)) diff --git a/src/h/rproto.h b/src/h/rproto.h new file mode 100644 index 0000000..3a5cc30 --- /dev/null +++ b/src/h/rproto.h @@ -0,0 +1,481 @@ +/* + * Prototypes for run-time functions. + */ + +/* + * Prototypes common to the compiler and interpreter. + */ +void EVInit (void); +int activate (dptr val, struct b_coexpr *ncp, dptr result); +word add (word a,word b); +void addmem (struct b_set *ps, struct b_selem *pe, union block **pl); +struct astkblk *alcactiv (void); +struct b_cset *alccset (void); +struct b_file *alcfile (FILE *fd,int status,dptr name); +union block *alchash (int tcode); +struct b_list *alclist (uword size); +struct b_lelem *alclstb (uword nslots,uword first,uword nused); +struct b_real *alcreal (double val); +struct b_slots *alcsegment (word nslots); +struct b_selem *alcselem (dptr mbr,uword hn); +char *alcstr (char *s,word slen); +struct b_telem *alctelem (void); +struct b_tvtbl *alctvtbl (dptr tbl,dptr ref,uword hashnum); +int anycmp (dptr dp1,dptr dp2); +int bfunc (void); +struct b_proc *bi_strprc (dptr s, C_integer arity); +void c_exit (int i); +int c_get (struct b_list *hp, struct descrip *res); +void c_put (struct descrip *l, struct descrip *val); +int cnv_c_dbl (dptr s, double *d); +int cnv_c_int (dptr s, C_integer *d); +int cnv_c_str (dptr s, dptr d); +int cnv_cset (dptr s, dptr d); +int cnv_ec_int (dptr s, C_integer *d); +int cnv_eint (dptr s, dptr d); +int cnv_int (dptr s, dptr d); +int cnv_real (dptr s, dptr d); +int cnv_str (dptr s, dptr d); +int cnv_tcset (struct b_cset *cbuf, dptr s, dptr d); +int cnv_tstr (char *sbuf, dptr s, dptr d); +int co_chng (struct b_coexpr *ncp, struct descrip *valloc, + struct descrip *rsltloc, + int swtch_typ, int first); +void co_init (struct b_coexpr *sblkp); +void coclean (word *old); +void coacttrace (struct b_coexpr *ccp,struct b_coexpr *ncp); +void cofailtrace (struct b_coexpr *ccp,struct b_coexpr *ncp); +void corettrace (struct b_coexpr *ccp,struct b_coexpr *ncp); +int coswitch (word *old, word *new, int first); +int cplist (dptr dp1,dptr dp2,word i,word j); +int cpset (dptr dp1,dptr dp2,word size); +void cpslots (dptr dp1,dptr slotptr,word i, word j); +int csetcmp (unsigned int *cs1,unsigned int *cs2); +int cssize (dptr dp); +word cvpos (long pos,long len); +void datainit (void); +void deallocate (union block *bp); +int def_c_dbl (dptr s, double df, double * d); +int def_c_int (dptr s, C_integer df, C_integer * d); +int def_c_str (dptr s, char * df, dptr d); +int def_cset (dptr s, struct b_cset * df, dptr d); +int def_ec_int (dptr s, C_integer df, C_integer * d); +int def_eint (dptr s, C_integer df, dptr d); +int def_int (dptr s, C_integer df, dptr d); +int def_real (dptr s, double df, dptr d); +int def_str (dptr s, dptr df, dptr d); +int def_tcset (struct b_cset *cbuf,dptr s,struct b_cset *df,dptr d); +int def_tstr (char *sbuf, dptr s, dptr df, dptr d); +word div3 (word a,word b); +int doasgn (dptr dp1,dptr dp2); +int doimage (int c,int q); +int dp_pnmcmp (struct pstrnm *pne,dptr dp); +void drunerr (int n, double v); +void dumpact (struct b_coexpr *ce); +void env_int (char *name,word *variable,int non_neg, uword limit); +int equiv (dptr dp1,dptr dp2); +int err (void); +void err_msg (int n, dptr v); +void error (char *s1, char *s2); +void fatalerr (int n,dptr v); +int findcol (word *ipc); +char *findfile (word *ipc); +int findipc (int line); +int findline (word *ipc); +int findloc (word *ipc); +void fpetrap (int); +int getvar (char *s,dptr vp); +uword hash (dptr dp); +union block **hchain (union block *pb,uword hn); +union block *hgfirst (union block *bp, struct hgstate *state); +union block *hgnext (union block*b,struct hgstate*s,union block *e); +union block *hmake (int tcode,word nslots,word nelem); +void icon_init (char *name, int *argcp, char *argv[]); +void iconhost (char *hostname); +int idelay (int n); +int interp (int fsig,dptr cargp); +void irunerr (int n, C_integer v); +int lexcmp (dptr dp1,dptr dp2); +word longread (char *s,int width,long len,FILE *fname); +union block **memb (union block *pb,dptr x,uword hn, int *res); +void mksubs (dptr var,dptr val,word i,word j, dptr result); +word mod3 (word a,word b); +word mul (word a,word b); +word neg (word a); +void new_context (int fsig, dptr cargp); /* w/o Coexpr: a stub */ +int numcmp (dptr dp1,dptr dp2,dptr dp3); +void outimage (FILE *f,dptr dp,int noimage); +struct b_coexpr *popact (struct b_coexpr *ce); +word prescan (dptr d); +int pstrnmcmp (struct pstrnm *a,struct pstrnm *b); +int pushact (struct b_coexpr *ce, struct b_coexpr *actvtr); +int putstr (FILE *f,dptr d); +char *qsearch (char *key, char *base, int nel, int width, + int (*cmp)()); +int qtos (dptr dp,char *sbuf); +int radix (int sign, register int r, register char *s, + register char *end_s, union numeric *result); +char *reserve (int region, word nbytes); +void retderef (dptr valp, word *low, word *high); +void segvtrap (int); +void stkdump (int); +word sub (word a,word b); +void syserr (char *s); +struct b_coexpr *topact (struct b_coexpr *ce); +void xmfree (void); + +#ifdef MultiThread + void resolve (struct progstate *pstate); + struct b_coexpr *loadicode (char *name, struct b_file *theInput, + struct b_file *theOutput, struct b_file *theError, + C_integer bs, C_integer ss, C_integer stk); + void actparent (int eventcode); + int mt_activate (dptr tvalp, dptr rslt, struct b_coexpr *ncp); +#else /* MultiThread */ + void resolve (void); +#endif /* MultiThread */ + +#ifdef EventMon + void EVAsgn (dptr dx); +#endif /* EventMon */ + +#ifdef ExternalFunctions + dptr extcall (dptr x, int nargs, int *signal); +#endif /* ExternalFunctions */ + +#ifdef LargeInts + struct b_bignum *alcbignum (word n); + word bigradix (int sign, int r, char *s, char *x, + union numeric *result); + double bigtoreal (dptr da); + int realtobig (dptr da, dptr dx); + int bigtos (dptr da, dptr dx); + void bigprint (FILE *f, dptr da); + int cpbignum (dptr da, dptr db); + int bigadd (dptr da, dptr db, dptr dx); + int bigsub (dptr da, dptr db, dptr dx); + int bigmul (dptr da, dptr db, dptr dx); + int bigdiv (dptr da, dptr db, dptr dx); + int bigmod (dptr da, dptr db, dptr dx); + int bigneg (dptr da, dptr dx); + int bigpow (dptr da, dptr db, dptr dx); + int bigpowri (double a, dptr db, dptr drslt); + int bigand (dptr da, dptr db, dptr dx); + int bigor (dptr da, dptr db, dptr dx); + int bigxor (dptr da, dptr db, dptr dx); + int bigshift (dptr da, dptr db, dptr dx); + word bigcmp (dptr da, dptr db); + int bigrand (dptr da, dptr dx); +#endif /* LargeInts */ + +#ifdef FAttrib + char *make_mode(mode_t st_mode); +#endif /* FAttrib */ + +#ifdef Graphics + /* + * portable graphics routines in rwindow.r and rwinrsc.r + */ + wcp alc_context (wbp w); + wbp alc_wbinding (void); + wsp alc_winstate (void); + int atobool (char *s); + void c_push (dptr l,dptr val); /* in fstruct.r */ + int docircles (wbp w, int argc, dptr argv, int fill); + void drawCurve (wbp w, XPoint *p, int n); + char *evquesub (wbp w, int i); + void genCurve (wbp w, XPoint *p, int n, void (*h)()); + wsp getactivewindow (void); + int getpattern (wbp w, char *answer); + struct palentry *palsetup(int p); + int palnum (dptr d); + int parsecolor (wbp w, char *s, long *r, long *g, long *b); + int parsefont (char *s, char *fam, int *sty, int *sz); + int parsegeometry (char *buf, SHORT *x, SHORT *y, SHORT *w, SHORT *h); + int parsepattern (char *s, int len, int *w, int *nbits, C_integer *bits); + void qevent (wsp ws, dptr e, int x, int y, uword t, long f); + int readGIF (char *fname, int p, struct imgdata *d); + int rectargs (wbp w, int argc, dptr argv, int i, + word *px, word *py, word *pw, word *ph); + char *rgbkey (int p, double r, double g, double b); + int setsize (wbp w, char *s); + char *si_i2s (siptr sip, int i); + int si_s2i (siptr sip, char *s); + int ulcmp (pointer p1, pointer p2); + int wattrib (wbp w, char *s, long len, dptr answer, char *abuf); + int wgetche (wbp w, dptr res); + int wgetchne (wbp w, dptr res); + int wgetevent (wbp w, dptr res); + int wgetstrg (char *s, long maxlen, FILE *f); + void wgoto (wbp w, int row, int col); + int wlongread (char *s, int elsize, int nelem, FILE *f); + void wputstr (wbp w, char *s, int len); + int writeGIF (wbp w, char *filename, + int x, int y, int width, int height); + int xyrowcol (dptr dx); + + /* + * graphics implementation routines supplied for each platform + * (excluding those defined as macros for X-windows) + */ + int SetPattern (wbp w, char *name, int len); + int SetPatternBits (wbp w, int width, C_integer *bits, int nbits); + int allowresize (wbp w, int on); + int blimage (wbp w, int x, int y, int wd, int h, + int ch, unsigned char *s, word len); + int capture (wbp w, int x, int y, int width, int hgt, short *data); + wcp clone_context (wbp w); + int copyArea (wbp w,wbp w2,int x,int y,int wd,int h,int x2,int y2); + int do_config (wbp w, int status); + int dumpimage (wbp w, char *filename, unsigned int x, unsigned int y, + unsigned int width, unsigned int height); + void eraseArea (wbp w, int x, int y, int width, int height); + void fillrectangles (wbp w, XRectangle *recs, int nrecs); + void free_binding (wbp w); + void free_context (wcp wc); + void free_mutable (wbp w, int mute_index); + int free_window (wsp ws); + void freecolor (wbp w, char *s); + char *get_mutable_name (wbp w, int mute_index); + void getbg (wbp w, char *answer); + void getcanvas (wbp w, char *s); + int getdefault (wbp w, char *prog, char *opt, char *answer); + void getdisplay (wbp w, char *answer); + void getdrawop (wbp w, char *answer); + void getfg (wbp w, char *answer); + void getfntnam (wbp w, char *answer); + void geticonic (wbp w, char *answer); + int geticonpos (wbp w, char *s); + void getlinestyle (wbp w, char *answer); + int getpixel_init (wbp w, struct imgmem *imem); + int getpixel_term (wbp w, struct imgmem *imem); + int getpixel (wbp w,int x,int y,long *rv,char *s,struct imgmem *im); + void getpointername (wbp w, char *answer); + int getpos (wbp w); + int getvisual (wbp w, char *answer); + int isetbg (wbp w, int bg); + int isetfg (wbp w, int fg); + int lowerWindow (wbp w); + int mutable_color (wbp w, dptr argv, int ac, int *retval); + int nativecolor (wbp w, char *s, long *r, long *g, long *b); + + int pollevent (void); + void wflush (wbp w); + + int query_pointer (wbp w, XPoint *pp); + int query_rootpointer (XPoint *pp); + int raiseWindow (wbp w); + int readimage (wbp w, char *filename, int x, int y, int *status); + int rebind (wbp w, wbp w2); + int set_mutable (wbp w, int i, char *s); + int setbg (wbp w, char *s); + int setcanvas (wbp w, char *s); + void setclip (wbp w); + int setcursor (wbp w, int on); + int setdisplay (wbp w, char *s); + int setdrawop (wbp w, char *val); + int setfg (wbp w, char *s); + int setfillstyle (wbp w, char *s); + int setfont (wbp w, char **s); + int setgamma (wbp w, double gamma); + int setgeometry (wbp w, char *geo); + int setheight (wbp w, SHORT new_height); + int seticonicstate (wbp w, char *s); + int seticonlabel (wbp w, char *val); + int seticonpos (wbp w, char *s); + int setimage (wbp w, char *val); + int setleading (wbp w, int i); + int setlinestyle (wbp w, char *s); + int setlinewidth (wbp w, LONG linewid); + int setpointer (wbp w, char *val); + int setwidth (wbp w, SHORT new_width); + int setwindowlabel (wbp w, char *val); + int strimage (wbp w, int x, int y, int width, int height, + struct palentry *e, unsigned char *s, + word len, int on_icon); + void toggle_fgbg (wbp w); + int walert (wbp w, int volume); + void warpPointer (wbp w, int x, int y); + int wclose (wbp w); + void wflush (wbp w); + int wgetq (wbp w, dptr res); + FILE *wopen (char *nm, struct b_list *hp, dptr attr, int n, int *e); + int wputc (int ci, wbp w); + #ifndef wsync + void wsync (wbp w); + #endif /* wsync */ + void xdis (wbp w, char *s, int n); + + #ifdef XWindows + /* + * Implementation routines specific to X-Windows + */ + void unsetclip (wbp w); + int moveResizeWindow (wbp w, int x, int y, int wd, int h); + int resetfg (wbp w); + int setfgrgb (wbp w, int r, int g, int b); + int setbgrgb (wbp w, int r, int g, int b); + + XColor xcolor (wbp w, LinearColor clr); + LinearColor lcolor (wbp w, XColor color); + int pixmap_open (wbp w, dptr attribs, int argc); + int pixmap_init (wbp w); + int remap (wbp w, int x, int y); + int seticonimage (wbp w, dptr dp); + int translate_key_event (XKeyEvent *k1, char *s, KeySym *k2); + wdp alc_display (char *s); + void free_display (wdp wd); + wfp alc_font (wbp w, char **s); + wfp tryfont (wbp w, char *s); + wclrp alc_rgb (wbp w, char *s, unsigned int r, + unsigned int g, unsigned int b, + int is_iconcolor); + int alc_centry (wdp wd); + wclrp alc_color (wbp w, char *s); + void copy_colors (wbp w1, wbp w2); + void free_xcolor (wbp w, unsigned long c); + void free_xcolors (wbp w, int extent); + int go_virtual (wbp w); + int resizePixmap (wbp w, int width, int height); + void wflushall (void); + #endif /* XWindows */ + + #ifdef WinGraphics + /* + * Implementation routines specific to MS Windows + */ + int playmedia (wbp w, char *s); + char *nativecolordialog (wbp w,long r,long g, long b,char *s); + int nativefontdialog (wbp w, char *buf, int flags, int fheight); + char *nativeopendialog (wbp w,char *s1,char *s2,char *s3,int i,int j); + char *nativeselectdialog (wbp w,struct b_list *,char *s); + char *nativesavedialog (wbp w,char *s1,char *s2,char *s3,int i,int j); + HFONT mkfont (char *s); + int sysTextWidth (wbp w, char *s, int n); + int sysFontHeight (wbp w); + int mswinsystem (char *s); + void UpdateCursorPos (wsp ws, wcp wc); + LRESULT_CALLBACK WndProc (HWND, UINT, WPARAM, LPARAM); + HDC CreateWinDC (wbp); + HDC CreatePixDC (wbp, HDC); + HBITMAP loadimage (wbp wb, char *filename, unsigned int *width, + unsigned int *height, int atorigin, int *status); + void wfreersc(); + int getdepth(wbp w); + HBITMAP CreateBitmapFromData(char *data); + int resizePixmap(wbp w, int width, int height); + int textWidth(wbp w, char *s, int n); + int seticonimage (wbp w, dptr dp); + int devicecaps(wbp w, int i); + void fillarcs(wbp wb, XArc *arcs, int narcs); + void drawarcs(wbp wb, XArc *arcs, int narcs); + void drawlines(wbinding *wb, XPoint *points, int npoints); + void drawpoints(wbinding *wb, XPoint *points, int npoints); + void drawrectangles(wbp wb, XRectangle *recs, int nrecs); + void fillpolygon(wbp w, XPoint *pts, int npts); + void drawsegments(wbinding *wb, XSegment *segs, int nsegs); + void drawstrng(wbinding *wb, int x, int y, char *s, int slen); + void unsetclip(wbp w); + + #endif /* WinGraphics */ + +#endif /* Graphics */ + +/* + * Prototypes for the run-time system. + */ + +struct b_external *alcextrnl (int n); +struct b_record *alcrecd (int nflds,union block *recptr); +struct b_tvsubs *alcsubs (word len,word pos,dptr var); +int bfunc (void); +long ckadd (long i, long j); +long ckmul (long i, long j); +long cksub (long i, long j); +void cmd_line (int argc, char **argv, dptr rslt); +struct b_coexpr *create (continuation fnc,struct b_proc *p,int ntmp,int wksz); +int collect (int region); +void cotrace (struct b_coexpr *ccp, struct b_coexpr *ncp, + int swtch_typ, dptr valloc); +int cvcset (dptr dp,int * *cs,int *csbuf); +int cvnum (dptr dp,union numeric *result); +int cvreal (dptr dp,double *r); +void deref (dptr dp1, dptr dp2); +void envset (void); +int eq (dptr dp1,dptr dp2); +int get_name (dptr dp1, dptr dp2); +int getch (void); +int getche (void); +double getdbl (dptr dp); +int getimage (dptr dp1, dptr dp2); +int getstrg (char *buf, int maxi, struct b_file *fbp); +void hgrow (union block *bp); +void hshrink (union block *bp); +C_integer iipow (C_integer n1, C_integer n2); +void init (char *name, int *argcp, char *argv[], int trc_init); +int kbhit (void); +int mkreal (double r,dptr dp); +int nthcmp (dptr d1,dptr d2); +void nxttab (C_integer *col, dptr *tablst, dptr endlst, + C_integer *last, C_integer *interval); +int order (dptr dp); +int printable (int c); +int ripow (double r, C_integer n, dptr rslt); +void rtos (double n,dptr dp,char *s); +int sig_rsm (void); +struct b_proc *strprc (dptr s, C_integer arity); +int subs_asgn (dptr dest, const dptr src); +int trcmp3 (struct dpair *dp1,struct dpair *dp2); +int trefcmp (dptr d1,dptr d2); +int tvalcmp (dptr d1,dptr d2); +int tvcmp4 (struct dpair *dp1,struct dpair *dp2); +int tvtbl_asgn (dptr dest, const dptr src); +void varargs (dptr argp, int nargs, dptr rslt); + +#ifdef MultiThread + struct b_coexpr *alccoexp (long icodesize, long stacksize); +#else /* MultiThread */ + struct b_coexpr *alccoexp (void); +#endif /* MultiThread */ + +#if COMPILER + + struct b_refresh *alcrefresh (int na, int nl, int nt, int wk_sz); + void atrace (void); + void ctrace (void); + void failtrace (void); + void initalloc (void); + int invoke (int n, dptr args, dptr rslt, continuation c); + void rtrace (void); + void strace (void); + void tracebk (struct p_frame *lcl_pfp, dptr argp); + int xdisp (struct p_frame *fp, dptr dp, int n, FILE *f); + +#else /* COMPILER */ + + struct b_refresh *alcrefresh (word *e, int nl, int nt); + void atrace (dptr dp); + void ctrace (dptr dp, int nargs, dptr arg); + void failtrace (dptr dp); + int invoke (int nargs, dptr *cargs, int *n); + void rtrace (dptr dp, dptr rval); + void strace (dptr dp, dptr rval); + void tracebk (struct pf_marker *lcl_pfp, dptr argp); + int xdisp (struct pf_marker *fp, dptr dp, int n, FILE *f); + + #define Fargs dptr cargp + int Obscan (int nargs, Fargs); + int Ocreate (word *entryp, Fargs); + int Oescan (int nargs, Fargs); + int Ofield (int nargs, Fargs); + int Olimit (int nargs, Fargs); + int Ollist (int nargs, Fargs); + int Omkrec (int nargs, Fargs); + + #ifdef MultiThread + void initalloc (word codesize, struct progstate *p); + #else /* MultiThread */ + void initalloc (word codesize); + #endif /* MultiThread */ + +#endif /* COMPILER */ diff --git a/src/h/rstructs.h b/src/h/rstructs.h new file mode 100644 index 0000000..5ee3fbb --- /dev/null +++ b/src/h/rstructs.h @@ -0,0 +1,555 @@ +/* + * Run-time data structures. + */ + +/* + * Structures common to the compiler and interpreter. + */ + +/* + * Run-time error numbers and text. + */ +struct errtab { + int err_no; /* error number */ + char *errmsg; /* error message */ + }; + +/* + * Descriptor + */ + +struct descrip { /* descriptor */ + word dword; /* type field */ + union { + word integr; /* integer value */ + char *sptr; /* pointer to character string */ + union block *bptr; /* pointer to a block */ + dptr descptr; /* pointer to a descriptor */ + } vword; + }; + +struct sdescrip { + word length; /* length of string */ + char *string; /* pointer to string */ + }; + +#ifdef LargeInts +struct b_bignum { /* large integer block */ + word title; /* T_Lrgint */ + word blksize; /* block size */ + word msd, lsd; /* most and least significant digits */ + int sign; /* sign; 0 positive, 1 negative */ + DIGIT digits[1]; /* digits */ + }; +#endif /* LargeInts */ + +struct b_real { /* real block */ + word title; /* T_Real */ + double realval; /* value */ + }; + +struct b_cset { /* cset block */ + word title; /* T_Cset */ + word size; /* size of cset */ + unsigned int bits[CsetSize]; /* array of bits */ + }; + +struct b_file { /* file block */ + word title; /* T_File */ + FILE *fd; /* Unix file descriptor */ + word status; /* file status */ + struct descrip fname; /* file name (string qualifier) */ + }; + +struct b_lelem { /* list-element block */ + word title; /* T_Lelem */ + word blksize; /* size of block */ + union block *listprev; /* previous list-element block */ + union block *listnext; /* next list-element block */ + word nslots; /* total number of slots */ + word first; /* index of first used slot */ + word nused; /* number of used slots */ + struct descrip lslots[1]; /* array of slots */ + }; + +struct b_list { /* list-header block */ + word title; /* T_List */ + word size; /* current list size */ + word id; /* identification number */ + union block *listhead; /* pointer to first list-element block */ + union block *listtail; /* pointer to last list-element block */ + }; + +struct b_proc { /* procedure block */ + word title; /* T_Proc */ + word blksize; /* size of block */ + + #if COMPILER + int (*ccode)(); + #else /* COMPILER */ + union { /* entry points for */ + int (*ccode)(); /* C routines */ + uword ioff; /* and icode as offset */ + pointer icode; /* and icode as absolute pointer */ + } entryp; + #endif /* COMPILER */ + + word nparam; /* number of parameters */ + word ndynam; /* number of dynamic locals */ + word nstatic; /* number of static locals */ + word fstatic; /* index (in global table) of first static */ + + struct descrip pname; /* procedure name (string qualifier) */ + struct descrip lnames[1]; /* list of local names (qualifiers) */ + }; + +struct b_record { /* record block */ + word title; /* T_Record */ + word blksize; /* size of block */ + word id; /* identification number */ + union block *recdesc; /* pointer to record constructor */ + struct descrip fields[1]; /* fields */ + }; + +/* + * Alternate uses for procedure block fields, applied to records. + */ +#define nfields nparam /* number of fields */ +#define recnum nstatic /* record number */ +#define recid fstatic /* record serial number */ +#define recname pname /* record name */ + +struct b_selem { /* set-element block */ + word title; /* T_Selem */ + union block *clink; /* hash chain link */ + uword hashnum; /* hash number */ + struct descrip setmem; /* the element */ + }; + +/* + * A set header must be a proper prefix of a table header, + * and a set element must be a proper prefix of a table element. + */ +struct b_set { /* set-header block */ + word title; /* T_Set */ + word size; /* size of the set */ + word id; /* identification number */ + word mask; /* mask for slot num, equals n slots - 1 */ + struct b_slots *hdir[HSegs]; /* directory of hash slot segments */ + }; + +struct b_table { /* table-header block */ + word title; /* T_Table */ + word size; /* current table size */ + word id; /* identification number */ + word mask; /* mask for slot num, equals n slots - 1 */ + struct b_slots *hdir[HSegs]; /* directory of hash slot segments */ + struct descrip defvalue; /* default table element value */ + }; + +struct b_slots { /* set/table hash slots */ + word title; /* T_Slots */ + word blksize; /* size of block */ + union block *hslots[HSlots]; /* array of slots (HSlots * 2^n entries) */ + }; + +struct b_telem { /* table-element block */ + word title; /* T_Telem */ + union block *clink; /* hash chain link */ + uword hashnum; /* for ordering chain */ + struct descrip tref; /* entry value */ + struct descrip tval; /* assigned value */ + }; + +struct b_tvsubs { /* substring trapped variable block */ + word title; /* T_Tvsubs */ + word sslen; /* length of substring */ + word sspos; /* position of substring */ + struct descrip ssvar; /* variable that substring is from */ + }; + +struct b_tvtbl { /* table element trapped variable block */ + word title; /* T_Tvtbl */ + union block *clink; /* pointer to table header block */ + uword hashnum; /* hash number */ + struct descrip tref; /* entry value */ + }; + +struct b_external { /* external block */ + word title; /* T_External */ + word blksize; /* size of block */ + word exdata[1]; /* words of external data */ + }; + +struct astkblk { /* co-expression activator-stack block */ + int nactivators; /* valid activator entries in this block */ + struct astkblk *astk_nxt; /* next activator block */ + struct actrec { /* activator record */ + word acount; /* number of calls by this activator */ + struct b_coexpr *activator; /* the activator itself */ + } arec[ActStkBlkEnts]; + }; + +/* + * Structure for keeping set/table generator state across a suspension. + */ +struct hgstate { /* hashed-structure generator state */ + int segnum; /* current segment number */ + word slotnum; /* current slot number */ + word tmask; /* structure mask before suspension */ + word sgmask[HSegs]; /* mask in use when the segment was created */ + uword sghash[HSegs]; /* hashnum in process when seg was created */ + }; + +/* + * Structure for chaining tended descriptors. + */ +struct tend_desc { + struct tend_desc *previous; + int num; + struct descrip d[1]; /* actual size of array indicated by num */ + }; + +/* + * Structure for mapping string names of functions and operators to block + * addresses. + */ +struct pstrnm { + char *pstrep; + struct b_proc *pblock; + }; + +struct dpair { + struct descrip dr; + struct descrip dv; + }; + +/* + * Allocated memory region structure. Each program has linked lists of + * string and block regions. + */ +struct region { + word size; /* allocated region size in bytes */ + char *base; /* start of region */ + char *end; /* end of region */ + char *free; /* free pointer */ + struct region *prev, *next; /* forms a linked list of regions */ + struct region *Gprev, *Gnext; /* global (all programs) lists */ + }; + +#ifdef Double + /* + * Data type the same size as a double but without alignment requirements. + */ + struct size_dbl { + char s[sizeof(double)]; + }; +#endif /* Double */ + +#if COMPILER + +/* + * Structures for the compiler. + */ + struct p_frame { + struct p_frame *old_pfp; + struct descrip *old_argp; + struct descrip *rslt; + continuation succ_cont; + struct tend_desc tend; + }; + #endif /* COMPILER */ + +/* + * when debugging is enabled a debug struct is placed after the tended + * descriptors in the procedure frame. + */ +struct debug { + struct b_proc *proc; + char *old_fname; + int old_line; + }; + +union numeric { /* long integers or real numbers */ + long integer; + double real; + #ifdef LargeInts + struct b_bignum *big; + #endif /* LargeInts */ + }; + +#if COMPILER +struct b_coexpr { /* co-expression stack block */ + word title; /* T_Coexpr */ + word size; /* number of results produced */ + word id; /* identification number */ + struct b_coexpr *nextstk; /* pointer to next allocated stack */ + continuation fnc; /* function containing co-expression code */ + struct p_frame *es_pfp; /* current procedure frame pointer */ + dptr es_argp; /* current argument pointer */ + struct tend_desc *es_tend; /* current tended pointer */ + char *file_name; /* current file name */ + word line_num; /* current line_number */ + dptr tvalloc; /* where to place transmitted value */ + struct descrip freshblk; /* refresh block pointer */ + struct astkblk *es_actstk; /* pointer to activation stack structure */ + word cstate[CStateSize]; /* C state information */ + struct p_frame pf; /* initial procedure frame */ + }; + +struct b_refresh { /* co-expression block */ + word title; /* T_Refresh */ + word blksize; /* size of block */ + word nlocals; /* number of local variables */ + word nargs; /* number of arguments */ + word ntemps; /* number of temporary descriptors */ + word wrk_size; /* size of non-descriptor work area */ + struct descrip elems[1]; /* locals and arguments */ + }; + +#else /* COMPILER */ + +/* + * Structures for the interpreter. + */ + +/* + * Declarations for entries in tables associating icode location with + * source program location. + */ +struct ipc_fname { + word ipc; /* offset of instruction into code region */ + word fname; /* offset of file name into string region */ + }; + +struct ipc_line { + word ipc; /* offset of instruction into code region */ + int line; /* line number */ + }; + +#ifdef MultiThread +/* + * Program state encapsulation. This consists of the VARIABLE parts of + * many global structures. + */ +struct progstate { + long hsize; /* size of the icode */ + struct progstate *parent; + struct descrip parentdesc; /* implicit "&parent" */ + struct descrip eventmask; /* implicit "&eventmask" */ + struct descrip opcodemask; /* implicit "&opcodemask" */ + struct descrip eventcode; /* &eventcode */ + struct descrip eventval; /* &eventval */ + struct descrip eventsource; /* &eventsource */ + dptr Glbl_argp; /* global argp */ + + /* + * trapped variable keywords' values + */ + struct descrip Kywd_err; + struct descrip Kywd_pos; + struct descrip ksub; + struct descrip Kywd_prog; + struct descrip Kywd_ran; + struct descrip Kywd_trc; + struct b_coexpr *Mainhead; + char *Code; + char *Ecode; + word *Records; + int *Ftabp; + #ifdef FieldTableCompression + short Ftabwidth, Foffwidth; + unsigned char *Ftabcp, *Focp; + short *Ftabsp, *Fosp; + int *Fo; + char *Bm; + #endif /* FieldTableCompression */ + dptr Fnames, Efnames; + dptr Globals, Eglobals; + dptr Gnames, Egnames; + dptr Statics, Estatics; + int NGlobals, NStatics; + char *Strcons; + struct ipc_fname *Filenms, *Efilenms; + struct ipc_line *Ilines, *Elines; + struct ipc_line * Current_line_ptr; + + #ifdef Graphics + struct descrip AmperX, AmperY, AmperRow, AmperCol;/* &x, &y, &row, &col */ + struct descrip AmperInterval; /* &interval */ + struct descrip LastEventWin; /* last Event() win */ + int LastEvFWidth; + int LastEvLeading; + int LastEvAscent; + uword PrevTimeStamp; /* previous timestamp */ + uword Xmod_Control, Xmod_Shift, Xmod_Meta; /* control,shift,meta */ + struct descrip Kywd_xwin[2]; /* &window + ... */ + #endif /* Graphics */ + + #ifdef EventMon + word Linenum, Column, Lastline, Lastcol; + #endif /* EventMon */ + + word Coexp_ser; /* this program's serial numbers */ + word List_ser; + word Set_ser; + word Table_ser; + + uword stringtotal; /* cumulative total allocation */ + uword blocktotal; /* cumulative total allocation */ + word colltot; /* total number of collections */ + word collstat; /* number of static collect requests */ + word collstr; /* number of string collect requests */ + word collblk; /* number of block collect requests */ + struct region *stringregion; + struct region *blockregion; + + word Lastop; + + dptr Xargp; + word Xnargs; + + struct descrip K_current; + int K_errornumber; + char *K_errortext; + struct descrip K_errorvalue; + int Have_errval; + int T_errornumber; + int T_have_val; + struct descrip T_errorvalue; + + struct descrip K_main; + struct b_file K_errout; + struct b_file K_input; + struct b_file K_output; + }; + +#endif /* MultiThread */ + +/* + * Frame markers + */ +struct ef_marker { /* expression frame marker */ + inst ef_failure; /* failure ipc */ + struct ef_marker *ef_efp; /* efp */ + struct gf_marker *ef_gfp; /* gfp */ + word ef_ilevel; /* ilevel */ + }; + +struct pf_marker { /* procedure frame marker */ + word pf_nargs; /* number of arguments */ + struct pf_marker *pf_pfp; /* saved pfp */ + struct ef_marker *pf_efp; /* saved efp */ + struct gf_marker *pf_gfp; /* saved gfp */ + dptr pf_argp; /* saved argp */ + inst pf_ipc; /* saved ipc */ + word pf_ilevel; /* saved ilevel */ + dptr pf_scan; /* saved scanning environment */ + + #ifdef MultiThread + struct progstate *pf_prog;/* saved program state pointer */ + #endif /* MultiThread */ + + struct descrip pf_locals[1]; /* descriptors for locals */ + }; + +struct gf_marker { /* generator frame marker */ + word gf_gentype; /* type */ + struct ef_marker *gf_efp; /* efp */ + struct gf_marker *gf_gfp; /* gfp */ + inst gf_ipc; /* ipc */ + struct pf_marker *gf_pfp; /* pfp */ + dptr gf_argp; /* argp */ + }; + +/* + * Generator frame marker dummy -- used only for sizing "small" + * generator frames where procedure information need not be saved. + * The first five members here *must* be identical to those for + * gf_marker. + */ +struct gf_smallmarker { /* generator frame marker */ + word gf_gentype; /* type */ + struct ef_marker *gf_efp; /* efp */ + struct gf_marker *gf_gfp; /* gfp */ + inst gf_ipc; /* ipc */ + }; + +/* + * b_iproc blocks are used to statically initialize information about + * functions. They are identical to b_proc blocks except for + * the pname field which is a sdescrip (simple/string descriptor) instead + * of a descrip. This is done because unions cannot be initialized. + */ + +struct b_iproc { /* procedure block */ + word ip_title; /* T_Proc */ + word ip_blksize; /* size of block */ + int (*ip_entryp)(); /* entry point (code) */ + word ip_nparam; /* number of parameters */ + word ip_ndynam; /* number of dynamic locals */ + word ip_nstatic; /* number of static locals */ + word ip_fstatic; /* index (in global table) of first static */ + + struct sdescrip ip_pname; /* procedure name (string qualifier) */ + struct descrip ip_lnames[1]; /* list of local names (qualifiers) */ + }; + +struct b_coexpr { /* co-expression stack block */ + word title; /* T_Coexpr */ + word size; /* number of results produced */ + word id; /* identification number */ + struct b_coexpr *nextstk; /* pointer to next allocated stack */ + struct pf_marker *es_pfp; /* current pfp */ + struct ef_marker *es_efp; /* efp */ + struct gf_marker *es_gfp; /* gfp */ + struct tend_desc *es_tend; /* current tended pointer */ + dptr es_argp; /* argp */ + inst es_ipc; /* ipc */ + word es_ilevel; /* interpreter level */ + word *es_sp; /* sp */ + dptr tvalloc; /* where to place transmitted value */ + struct descrip freshblk; /* refresh block pointer */ + struct astkblk *es_actstk; /* pointer to activation stack structure */ + + #ifdef MultiThread + struct progstate *program; + #endif /* MultiThread */ + + word cstate[CStateSize]; /* C state information */ + }; + +struct b_refresh { /* co-expression block */ + word title; /* T_Refresh */ + word blksize; /* size of block */ + word *ep; /* entry point */ + word numlocals; /* number of locals */ + struct pf_marker pfmkr; /* marker for enclosing procedure */ + struct descrip elems[1]; /* arguments and locals, including Arg0 */ + }; + +#endif /* COMPILER */ + +union block { /* general block */ + struct b_real realblk; + struct b_cset cset; + struct b_file file; + struct b_proc proc; + struct b_list list; + struct b_lelem lelem; + struct b_table table; + struct b_telem telem; + struct b_set set; + struct b_selem selem; + struct b_record record; + struct b_tvsubs tvsubs; + struct b_tvtbl tvtbl; + struct b_refresh refresh; + struct b_coexpr coexpr; + struct b_external externl; + struct b_slots slots; + + #ifdef LargeInts + struct b_bignum bignumblk; + #endif /* LargeInts */ + }; diff --git a/src/h/rt.h b/src/h/rt.h new file mode 100644 index 0000000..4531dc9 --- /dev/null +++ b/src/h/rt.h @@ -0,0 +1,27 @@ +#ifndef RT_DOT_H /* only include once */ +#define RT_DOT_H 1 + +/* + * Include files. + */ + +#include "../h/define.h" +#include "../h/arch.h" +#include "../h/config.h" +#include "../h/sys.h" +#include "../h/typedefs.h" +#include "../h/cstructs.h" +#include "../h/mproto.h" +#include "../h/cpuconf.h" +#include "../h/monitor.h" +#include "../h/rmacros.h" +#include "../h/rstructs.h" + +#ifdef Graphics + #include "../h/graphics.h" +#endif /* Graphics */ + +#include "../h/rexterns.h" +#include "../h/rproto.h" + +#endif /* RT_DOT_H */ diff --git a/src/h/sys.h b/src/h/sys.h new file mode 100644 index 0000000..fecfd96 --- /dev/null +++ b/src/h/sys.h @@ -0,0 +1,75 @@ +/* + * sys.h -- system include files. + */ + +/* + * Universal (Standard 1989 ANSI C) includes. + */ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +/* + * POSIX (1003.1-1996) includes. + */ +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include +#include + +/* + * Operating-system-dependent includes. + */ +#if MSWIN + #include + #include + #include + + #ifdef WinGraphics + #define int_PASCAL int PASCAL + #define LRESULT_CALLBACK LRESULT CALLBACK + #define BOOL_CALLBACK BOOL CALLBACK + #include + #include + #include "../wincap/dibutil.h" + #endif /* WinGraphics */ + + #undef Type + #undef lst1 + #undef lst2 +#endif /* MSWIN */ + +/* + * Window-system-dependent includes. + */ +#ifdef XWindows + #ifdef HaveXpmFormat + #include "../xpm/xpm.h" + #else /* HaveXpmFormat */ + #include + #endif /* HaveXpmFormat */ + #include + #include + #include +#endif /* XWindows */ + +/* + * Feature-dependent includes. + */ +#ifdef LoadFunc + #include +#endif /* LoadFunc */ diff --git a/src/h/typedefs.h b/src/h/typedefs.h new file mode 100644 index 0000000..984af9a --- /dev/null +++ b/src/h/typedefs.h @@ -0,0 +1,81 @@ +/* + * typedefs for the run-time system. + */ + +typedef int ALIGN; /* pick most stringent type for alignment */ +typedef unsigned int DIGIT; + +/* + * Default sizing and such. + */ + +/* + * Set up typedefs and related definitions depending on whether or not + * ints and pointers are the same size. + */ + +#if IntBits != WordBits + typedef long int word; + typedef unsigned long int uword; +#else /* IntBits != WordBits */ + typedef int word; + typedef unsigned int uword; +#endif /* IntBits != WordBits */ + +typedef void *pointer; + +/* + * Typedefs to make some things easier. + */ + +typedef int (*fptr)(); +typedef struct descrip *dptr; + +typedef word C_integer; + +/* + * A success continuation is referenced by a pointer to an integer function + * that takes no arguments. + */ +typedef int (*continuation) (void); + +#if !COMPILER + + /* + * Typedefs for the interpreter. + */ + + /* + * Icode consists of operators and arguments. Operators are small integers, + * while arguments may be pointers. To conserve space in icode files on + * computers with 16-bit ints, icode is written by the linker as a mixture + * of ints and words (longs). When an icode file is read in and processed + * by the interpreter, it looks like a C array of mixed ints and words. + * Accessing this "nonstandard" structure is handled by a union of int and + * word pointers and incrementing is done by incrementing the appropriate + * member of the union (see the interpreter). This is a rather dubious + * method and certainly not portable. A better way might be to address + * icode with a char *, but the incrementing code might be inefficient + * (at a place that experiences a lot of execution activity). + * + * For the moment, the dubious coding is isolated under control of the + * size of integers. + */ + + #if IntBits != WordBits + + typedef union { + int *op; + word *opnd; + } inst; + + #else /* IntBits != WordBits */ + + typedef union { + word *op; + word *opnd; + } inst; + + #endif /* IntBits != WordBits */ + +#endif /* COMPILER */ diff --git a/src/h/version.h b/src/h/version.h new file mode 100644 index 0000000..c3a8b8d --- /dev/null +++ b/src/h/version.h @@ -0,0 +1,66 @@ +/* + * version.h -- version identification + */ + +#undef DVersion +#undef Version +#undef UVersion +#undef IVersion + +/* + * Icon version number and date. + * These are the only two entries that change any more. + */ +#define VersionNumber "9.4.3" +#define VersionDate "November 14, 2005" + +/* + * Version number to insure format of data base matches version of iconc + * and rtt. + */ +#define DVersion "9.0.00" + +#if COMPILER + + /* + * &version + */ + #define Version "Icon Version " VersionNumber "-C, " VersionDate + +#else /* COMPILER */ + + /* + * &version + */ + #define Version "Icon Version " VersionNumber ", " VersionDate + + /* + * Version numbers to be sure that ucode is compatible with the linker + * and that icode is compatible with the run-time system. + */ + + #define UVersion "U9.0.00" + + #ifdef FieldTableCompression + + #if IntBits == 32 + #define IVersion "I9.2.00FT/32" + #endif /* IntBits == 32 */ + + #if IntBits == 64 + #define IVersion "I9.2.00FT/64" + #endif /* IntBits == 64 */ + + #else /* FieldTableCompression */ + + #if IntBits == 32 + #define IVersion "I9.0.00/32" + #endif /* IntBits == 32 */ + + #if IntBits == 64 + #define IVersion "I9.0.00/64" + #endif /* IntBits == 64 */ + + #endif /* FieldTableCompression */ + +#endif /* COMPILER */ diff --git a/src/h/xwin.h b/src/h/xwin.h new file mode 100644 index 0000000..a8ff24c --- /dev/null +++ b/src/h/xwin.h @@ -0,0 +1,194 @@ +#ifdef XWindows + +#define DRAWOP_AND GXand +#define DRAWOP_ANDINVERTED GXandInverted +#define DRAWOP_ANDREVERSE GXandReverse +#define DRAWOP_CLEAR GXclear +#define DRAWOP_COPY GXcopy +#define DRAWOP_COPYINVERTED GXcopyInverted +#define DRAWOP_EQUIV GXequiv +#define DRAWOP_INVERT GXinvert +#define DRAWOP_NAND GXnand +#define DRAWOP_NOOP GXnoop +#define DRAWOP_NOR GXnor +#define DRAWOP_OR GXor +#define DRAWOP_ORINVERTED GXorInverted +#define DRAWOP_ORREVERSE GXorReverse +#define DRAWOP_REVERSE 0x10 +#define DRAWOP_SET GXset +#define DRAWOP_XOR GXxor + +#define XLFD_Foundry 1 +#define XLFD_Family 2 +#define XLFD_Weight 3 +#define XLFD_Slant 4 +#define XLFD_SetWidth 5 +#define XLFD_AddStyle 6 +#define XLFD_Size 7 +#define XLFD_PointSize 8 +#define XLFD_Spacing 11 +#define XLFD_CharSet 13 + +#define TEXTWIDTH(w,s,n) XTextWidth((w)->context->font->fsp, s, n) +#define SCREENDEPTH(w)\ + DefaultDepth((w)->window->display->display, w->window->display->screen) +#define ASCENT(w) ((w)->context->font->fsp->ascent) +#define DESCENT(w) ((w)->context->font->fsp->descent) +#define LEADING(w) ((w)->context->leading) +#define FHEIGHT(w) ((w)->context->font->height) +#define FWIDTH(w) ((w)->context->font->fsp->max_bounds.width) +#define LINEWIDTH(w) ((w)->context->linewidth) +#define DISPLAYHEIGHT(w)\ + DisplayHeight(w->window->display->display, w->window->display->screen) +#define DISPLAYWIDTH(w)\ + DisplayWidth(w->window->display->display, w->window->display->screen) +#define FS_SOLID FillSolid +#define FS_STIPPLE FillStippled +#define hidecrsr(x) /* noop */ +#define UpdateCursorPos(x, y) /* noop */ +#define showcrsr(x) /* noop */ +#define SysColor XColor +#define ARCWIDTH(arc) ((arc).width) +#define ARCHEIGHT(arc) ((arc).height) +#define RECX(rec) ((rec).x) +#define RECY(rec) ((rec).y) +#define RECWIDTH(rec) ((rec).width) +#define RECHEIGHT(rec) ((rec).height) +#define ANGLE(ang) (-(ang) * 180 / Pi * 64) +#define EXTENT(ang) (-(ang) * 180 / Pi * 64) +#define ISICONIC(w) ((w)->window->iconic == IconicState) +#define ISFULLSCREEN(w) (0) +#define ISROOTWIN(w) ((w)->window->iconic == RootState) +#define ISNORMALWINDOW(w) ((w)->window->iconic == NormalState) +#define ICONFILENAME(w) ((w)->window->iconimage) +#define ICONLABEL(w) ((w)->window->iconlabel) +#define WINDOWLABEL(w) ((w)->window->windowlabel) +#define RootState IconicState+1 +#define MaximizedState IconicState+2 +#define HiddenState IconicState+3 + +/* + * The following constants define limitations in the system, gradually being + * removed as this code is rewritten to use dynamic allocation. + */ +#define WMAXCOLORS 256 +#define MAXCOLORNAME 40 +#define MAXDISPLAYNAME 64 +#define SHARED 0 +#define MUTABLE 1 +#define NUMCURSORSYMS 78 + +/* + * Macros to ease coding in which every X call must be done twice. + */ +#define RENDER2(func,v1,v2) {\ + if (stdwin) func(stddpy, stdwin, stdgc, v1, v2); \ + func(stddpy, stdpix, stdgc, v1, v2);} +#define RENDER3(func,v1,v2,v3) {\ + if (stdwin) func(stddpy, stdwin, stdgc, v1, v2, v3); \ + func(stddpy, stdpix, stdgc, v1, v2, v3);} +#define RENDER4(func,v1,v2,v3,v4) {\ + if (stdwin) func(stddpy, stdwin, stdgc, v1, v2, v3, v4); \ + func(stddpy, stdpix, stdgc, v1, v2, v3, v4);} +#define RENDER6(func,v1,v2,v3,v4,v5,v6) {\ + if (stdwin) func(stddpy, stdwin, stdgc, v1, v2, v3, v4, v5, v6); \ + func(stddpy, stdpix, stdgc, v1, v2, v3, v4, v5, v6);} +#define RENDER7(func,v1,v2,v3,v4,v5,v6,v7) {\ + if (stdwin) func(stddpy, stdwin, stdgc, v1, v2, v3, v4, v5, v6, v7); \ + func(stddpy, stdpix, stdgc, v1, v2, v3, v4, v5, v6, v7);} + +#define MAXDESCENDER(w) (w->context->font->fsp->max_bounds.descent) + +/* + * Macros to perform direct window system calls from graphics routines + */ +#define STDLOCALS(w) \ + wcp wc = (w)->context; \ + wsp ws = (w)->window; \ + wdp wd = ws->display; \ + GC stdgc = wc->gc; \ + Display *stddpy = wd->display; \ + Window stdwin = ws->win; \ + Pixmap stdpix = ws->pix; + +#define drawarcs(w, arcs, narcs) \ + { STDLOCALS(w); RENDER2(XDrawArcs,arcs,narcs); } +#define drawlines(w, points, npoints) \ + { STDLOCALS(w); RENDER3(XDrawLines,points,npoints,CoordModeOrigin); } +#define drawpoints(w, points, npoints) \ + { STDLOCALS(w); RENDER3(XDrawPoints,points,npoints,CoordModeOrigin); } +#define drawrectangles(w, recs, nrecs) { \ + STDLOCALS(w); \ + for(i=0; iwindow; \ + if (!c_get((struct b_list *)BlkLoc(ws->listp),&d)) fatalerr(0,NULL); \ + if (Qual(d)) {\ + ws->eventQueue[ws->eQfront++] = *StrLoc(d); \ + if (ws->eQfront >= EQUEUELEN) ws->eQfront = 0; \ + ws->eQback = ws->eQfront; \ + } \ + } +#define EVQUEEMPTY(w) (BlkLoc((w)->window->listp)->list.size == 0) + +/* + * Colors. These are allocated within displays. Pointers + * into the display's color table are also kept on a per-window + * basis so that they may be (de)allocated when a window is cleared. + * Colors are aliased by r,g,b value. Allocations by name and r,g,b + * share when appropriate. + * + * Color (de)allocation comprises a simple majority of the space + * requirements of the current implementation. A monochrome-only + * version would take a lot less space. + * + * The name field is the string returned by WAttrib. For a mutable + * color this is of the form "-47" followed by a second C string + * containing the current color setting. + */ +typedef struct wcolor { + unsigned long c; /* X pixel value */ + int refcount; /* reference count */ + int type; /* SHARED or MUTABLE */ + int next; /* next entry in hash chain */ + unsigned short r, g, b; /* rgb for colorsearch */ + char name[6+MAXCOLORNAME]; /* name for WAttrib & WColor reads */ +} *wclrp; + +/* + * macros performing row/column to pixel y,x translations + * computation is 1-based and depends on the current font's size. + * exception: XTOCOL as defined is 0-based, because that's what its + * clients seem to need. + */ +#define ROWTOY(w,row) ((row-1) * LEADING(w) + ASCENT(w)) +#define COLTOX(w,col) ((col-1) * FWIDTH(w)) +#define YTOROW(w,y) ((y>0) ? ((y) / LEADING(w) + 1) : ((y) / LEADING(w))) +#define XTOCOL(w,x) (!FWIDTH(w) ? (x) : ((x) / FWIDTH(w))) + +#define STDLOCALS(w) \ + wcp wc = (w)->context; \ + wsp ws = (w)->window; \ + wdp wd = ws->display; \ + GC stdgc = wc->gc; \ + Display *stddpy = wd->display; \ + Window stdwin = ws->win; \ + Pixmap stdpix = ws->pix; + +#endif /* XWindows */ diff --git a/src/iconc/Makefile b/src/iconc/Makefile new file mode 100644 index 0000000..bce6aa8 --- /dev/null +++ b/src/iconc/Makefile @@ -0,0 +1,73 @@ +# Makefile for the Icon compiler, iconc. +# +# This is no longer supported and may not work. + +include ../../Makedefs + + +OBJS = cmain.o ctrans.o dbase.o clex.o\ + cparse.o csym.o cmem.o ctree.o ccode.o ccomp.o\ + ivalues.o codegen.o fixcode.o inline.o chkinv.o\ + typinfer.o types.o lifetime.o incheck.o + +COBJS = ../common/long.o ../common/getopt.o ../common/time.o\ + ../common/filepart.o ../common/identify.o ../common/munix.o\ + ../common/strtbl.o ../common/rtdb.o ../common/literals.o \ + ../common/alloc.o ../common/ipp.o + + + +iconc: $(OBJS) $(COBJS) + $(CC) -o iconc $(OBJS) $(COBJS) + cp iconc ../../bin + strip ../../bin/iconc$(EXE) + +$(OBJS): ../h/config.h ../h/cpuconf.h ../h/cstructs.h ../h/define.h\ + ../h/mproto.h ../h/typedefs.h ../h/gsupport.h \ + ccode.h cglobals.h cproto.h csym.h ctrans.h ctree.h + +$(COBJS): ../h/mproto.h + cd ../common; $(MAKE); $(MAKE) xpm + +ccode.o: ../h/lexdef.h ctoken.h +chkinv.o: ctoken.h +clex.o: ../h/lexdef.h ../h/parserr.h ctoken.h \ + ../common/lextab.h ../common/yylex.h ../common/error.h +clocal.o: ../h/config.h +cparse.o: ../h/lexdef.h +ctrans.o: ctoken.h +ctree.o: ../h/lexdef.h ctoken.h +csym.o: ctoken.h +dbase.o: ../h/lexdef.h +lifetime.o: ../h/lexdef.h ctoken.h +typinfer.o: ../h/lexdef.h ctoken.h +types.o: ../h/lexdef.h ctoken.h + + + +# The following sections are commented out because they do not need to +# be performed unless changes are made to cgrammar.c, ../h/grammar.h, +# ../common/tokens.txt, or ../common/op.txt. Such changes involve +# modifications to the syntax of Icon and are not part of the installation +# process. However, if the distribution files are unloaded in a fashion +# such that their dates are not set properly, the following sections would +# be attempted. +# +# Note that if any changes are made to the files mentioned above, the comment +# characters at the beginning of the following lines should be removed. +# icont must be on your search path for these actions to work. +# +#../common/lextab.h ../common/yacctok.h ../common/fixgram ../common/pscript: \ +# ../common/tokens.txt ../common/op.txt +# cd ../common; $(MAKE) gfiles +# +#cparse.c ctoken.h: cgram.g ../common/pscript +## expect 218 shift/reduce conflicts +# yacc -d cgram.g +# ../common/pscript cparse.c +# mv y.tab.h ctoken.h +# rm -f y.tab.c +# +#cgram.g: cgrammar.c ../h/define.h ../h/grammar.h \ +# ../common/yacctok.h ../common/fixgram +# $(CC) -E -C cgrammar.c | ../common/fixgram >cgram.g diff --git a/src/iconc/ccode.c b/src/iconc/ccode.c new file mode 100644 index 0000000..108cd15 --- /dev/null +++ b/src/iconc/ccode.c @@ -0,0 +1,4954 @@ +/* + * ccode.c - routines to produce internal representation of C code. + */ +#include "../h/gsupport.h" +#include "../h/lexdef.h" +#include "ctrans.h" +#include "cglobals.h" +#include "csym.h" +#include "ccode.h" +#include "ctree.h" +#include "ctoken.h" +#include "cproto.h" + +#ifdef OptimizeLit + +#define NO_LIMIT 0 +#define LIMITED 1 +#define LIMITED_TO_INT 2 +#define NO_TOUCH 3 + +struct lit_tbl { + int modified; + int index; + int safe; + struct code *initial; + struct code *end; + struct val_loc *vloc; + struct centry *csym; + struct lit_tbl *prev; + struct lit_tbl *next; +}; +#endif /* OptimizeLit */ + +/* + * Prototypes for static functions. + */ +static struct c_fnc *alc_fnc (void); +static struct tmplftm *alc_lftm (int num, union field *args); +static int alc_tmp (int n, struct tmplftm *lifetm_ary); + +#ifdef OptimizePoll + static int analyze_poll (void); + static void remove_poll (void); +#endif /* OptimizePoll */ + +#ifdef OptimizeLit + static int instr (const char *str, int chr); + static void invalidate (struct val_loc *val,struct code *end,int code); + static void analyze_literals (struct code *start, struct code *top, int lvl); + static int eval_code (struct code *cd, struct lit_tbl *cur); + static void propagate_literals (void); + static void free_tbl (void); + static struct lit_tbl *alc_tbl (void); + static void tbl_add (truct lit_tbl *add); +#endif /* OptimizeLit */ + +static struct code *asgn_null (struct val_loc *loc1); +static struct val_loc *bound (struct node *n, struct val_loc *rslt, + int catch_fail); +static struct code *check_var (struct val_loc *d, struct code *lbl); +static void deref_cd (struct val_loc *src, struct val_loc *dest); +static void deref_ret (struct val_loc *src, struct val_loc *dest, + int subtypes); +static void endlife (int kind, int indx, int old, nodeptr n); +static struct val_loc *field_ref(struct node *n, struct val_loc *rslt); +static struct val_loc *gen_act (nodeptr n, struct val_loc *rslt); +static struct val_loc *gen_apply(struct node *n, struct val_loc *rslt); +static struct val_loc *gen_args (struct node *n, int frst_arg, int nargs); +static struct val_loc *gen_case (struct node *n, struct val_loc *rslt); +static struct val_loc *gen_creat(struct node *n, struct val_loc *rslt); +static struct val_loc *gen_lim (struct node *n, struct val_loc *rslt); +static struct val_loc *gen_scan (struct node *n, struct val_loc *rslt); +static struct val_loc *gencode (struct node *n, struct val_loc *rslt); +static struct val_loc *genretval(struct node *n, struct node *expr, + struct val_loc *dest); +static struct val_loc *inv_prc (nodeptr n, struct val_loc *rslt); +static struct val_loc *inv_op (nodeptr n, struct val_loc *rslt); +static nodeptr max_lftm (nodeptr n1, nodeptr n2); +static void mk_callop (char *oper_nm, int ret_flag, + struct val_loc *arg1rslt, int nargs, + struct val_loc *rslt, int optim); +static struct code *mk_cpyval (struct val_loc *loc1, struct val_loc *loc2); +static struct code *new_call (void); +static char *oper_name (struct implement *impl); +static void restr_env (struct val_loc *sub_sav, struct val_loc *pos_sav); +static void save_env (struct val_loc *sub_sav, struct val_loc *pos_sav); +static void setloc (nodeptr n); +static struct val_loc *tmp_loc (int n); +static struct val_loc *var_ref (struct lentry *sym); +static struct val_loc *vararg_sz(int n); + +#define FrstArg 2 + +/* + * Information that must be passed between a loop and its next and break + * expressions. + */ +struct loop_info { + struct code *next_lbl; /* where to branch for a next expression */ + struct code *end_loop; /* label at end of loop */ + struct code *on_failure; /* where to go if the loop fails */ + struct scan_info *scan_info; /* scanning environment upon entering loop */ + struct val_loc *rslt; /* place to put result of loop */ + struct c_fnc *succ_cont; /* the success continuation for the loop */ + struct loop_info *prev; /* link to info for outer loop */ + }; + +/* + * The allocation status of a temporary variable can either be "in use", + * "not allocated", or reserved for use at a code position (indicated + * by a specific negative number). + */ +#define InUse 1 +#define NotAlc 0 + +/* + * tmplftm is used to precompute lifetime information for use in allocating + * temporary variables. + */ +struct tmplftm { + int cur_status; + nodeptr lifetime; + }; + +/* + * Places where &subject and &pos are saved during string scanning. "outer" + * values are saved when the scanning expression is executed. "inner" + * values are saved when the scanning expression suspends. + */ +struct scan_info { + struct val_loc *outer_sub; + struct val_loc *outer_pos; + struct val_loc *inner_sub; + struct val_loc *inner_pos; + struct scan_info *next; + }; + +struct scan_info scan_base = {NULL, 0, NULL, 0, NULL}; +struct scan_info *nxt_scan = &scan_base; + +struct val_loc ignore; /* no values, just something to point at */ +static struct val_loc proc_rslt; /* result location for procedure */ + +int *tmp_status = NULL; /* allocation status of temp descriptor vars */ +int *itmp_status = NULL; /* allocation status of temp C int vars*/ +int *dtmp_status = NULL; /* allocation status of temp C double vars */ +int *sbuf_status = NULL; /* allocation of string buffers */ +int *cbuf_status = NULL; /* allocation of cset buffers */ +int num_tmp; /* number of temp descriptors actually used */ +int num_itmp; /* number of temp C ints actually used */ +int num_dtmp; /* number of temp C doubles actually used */ +int num_sbuf; /* number of string buffers actually used */ +int num_cbuf; /* number of cset buffers actually used */ +int status_sz = 20; /* current size of tmp_status array */ +int istatus_sz = 20; /* current size of itmp_status array */ +int dstatus_sz = 20; /* current size of dtmp_status array */ +int sstatus_sz = 20; /* current size of sbuf_status array */ +int cstatus_sz = 20; /* current size of cbuf_status array */ +struct freetmp *freetmp_pool = NULL; + +static char frm_prfx[PrfxSz + 1];/* prefix for procedure frame */ +static char *lastfiln; /* last file name set in code */ +static int lastline; /* last line number set in code */ + +#ifdef OptimizePoll +static struct code *lastpoll; +#endif /* OptimizePoll */ + +#ifdef OptimizeLit +static struct lit_tbl *tbl = NULL; +static struct lit_tbl *free_lit_tbl = NULL; +#endif /* OptimizeLit */ + +static struct c_fnc *fnc_lst; /* list of C functions implementing proc */ +static struct c_fnc **flst_end; /* pointer to null pointer at end of fnc_lst */ +struct c_fnc *cur_fnc; /* C function currently being built */ +static int create_lvl = 0; /* co-expression create level */ + +struct pentry *cur_proc; /* procedure currently being translated */ + +struct code *on_failure; /* place to go on failure */ + +static struct code *p_ret_lbl; /* label for procedure return */ +static struct code *p_fail_lbl; /* label for procedure fail */ +struct code *bound_sig; /* bounding signal for current procedure */ + +/* + * statically declared "signals". + */ +struct code resume; +struct code contin; +struct code fallthru; +struct code next_fail; + +int lbl_seq_num = 0; /* next label sequence number */ + +#ifdef OptimizeLit +static void print_tbl(struct lit_tbl *start) { + struct lit_tbl *ptr; + + for (ptr=start; ptr != NULL ;ptr=ptr->next) { + printf("mod (%2d) strchr (%2d) ",ptr->modified,ptr->index); + if (ptr->csym != NULL) { + printf("image (%13s) ",ptr->csym->image); + } + if (ptr->vloc != NULL) { + printf("val (%6d) type (%d)",ptr->vloc->u.tmp,ptr->vloc->loc_type); + } + if (ptr->end == NULL) + printf(" END IS NULL"); + printf("\n"); + } +} + + +static void free_tbl() { +/* + struct lit_tbl *ptr, *next; +*/ + free_lit_tbl = tbl; + tbl = NULL; +/* + ptr = tbl; + while (ptr != NULL) { + next = ptr->next; + free(ptr); + ptr = next; + } + tbl = NULL; +*/ +} + + +static struct lit_tbl *alc_tbl() { + struct lit_tbl *new; + static int cnt=0; + + + if (free_lit_tbl != NULL) { + new = free_lit_tbl; + free_lit_tbl = new->next; + } + else + new = (struct lit_tbl *)alloc(sizeof(struct lit_tbl)); + new->modified = NO_LIMIT; + new->index = -1; + new->safe = 1; + new->initial = NULL; + new->end = NULL; + new->vloc = NULL; + new->csym = NULL; + new->prev = NULL; + new->next = NULL; + return new; +} +#endif /* OptimizeLit */ + +/* + * proccode - generate code for a procedure. + */ +void proccode(proc) +struct pentry *proc; + { + struct c_fnc *fnc; + struct code *cd; + struct code *cd1; + struct code *lbl; + nodeptr n; + nodeptr failer; + int gen; + int i; +#ifdef OptimizeLit + struct code *procstart; +#endif /* OptimizeLit */ + + /* + * Initialize arrays used for allocating temporary variables. + */ + if (tmp_status == NULL) + tmp_status = (int *)alloc((unsigned int)(status_sz * sizeof(int))); + if (itmp_status == NULL) + itmp_status = (int *)alloc((unsigned int)(istatus_sz * sizeof(int))); + if (dtmp_status == NULL) + dtmp_status = (int *)alloc((unsigned int)(dstatus_sz * sizeof(int))); + if (sbuf_status == NULL) + sbuf_status = (int *)alloc((unsigned int)(sstatus_sz * sizeof(int))); + if (cbuf_status == NULL) + cbuf_status = (int *)alloc((unsigned int)(cstatus_sz * sizeof(int))); + for (i = 0; i < status_sz; ++i) + tmp_status[i] = NotAlloc; + for (i = 0; i < istatus_sz; ++i) + itmp_status[i] = NotAlloc; + for (i = 0; i < dstatus_sz; ++i) + dtmp_status[i] = NotAlloc; + for (i = 0; i < sstatus_sz; ++i) + sbuf_status[i] = NotAlloc; + for (i = 0; i < cstatus_sz; ++i) + cbuf_status[i] = NotAlloc; + num_tmp = 0; + num_itmp = 0; + num_dtmp = 0; + num_sbuf = 0; + num_cbuf = 0; + + /* + * Initialize standard signals. + */ + resume.cd_id = C_Resume; + contin.cd_id = C_Continue; + fallthru.cd_id = C_FallThru; + + /* + * Initialize procedure result and the transcan locations. + */ + proc_rslt.loc_type = V_PRslt; + proc_rslt.mod_access = M_None; + ignore.loc_type = V_Ignore; + ignore.mod_access = M_None; + + cur_proc = proc; /* current procedure */ + lastfiln = NULL; /* file name */ + lastline = 0; /* line number */ + +#ifdef OptimizePoll + lastpoll = NULL; +#endif /* OptimizePoll */ + + /* + * Procedure frame prefix is the procedure prefix. + */ + for (i = 0; i < PrfxSz; ++i) + frm_prfx[i] = cur_proc->prefix[i]; + frm_prfx[PrfxSz] = '\0'; + + /* + * Initialize the continuation list and allocate the outer function for + * this procedure. + */ + fnc_lst = NULL; + flst_end = &fnc_lst; + cur_fnc = alc_fnc(); + +#ifdef OptimizeLit + procstart = cur_fnc->cursor; +#endif /* OptimizeLit */ + + /* + * If the procedure is not used anywhere don't generate code for it. + * This can happen when using libraries containing several procedures, + * but not all are needed. However, if there is a block for the + * procedure, we need at least a dummy function. + */ + if (!cur_proc->reachable) { + if (!(glookup(cur_proc->name)->flag & F_SmplInv)) + outerfnc(fnc_lst); + return; + } + + /* + * Allocate labels for the code for procedure failure, procedure return, + * and allocate the bounding signal for this procedure (at this point + * signals and labels are not distinguished). + */ + p_fail_lbl = alc_lbl("proc fail", 0); + p_ret_lbl = alc_lbl("proc return", 0); + bound_sig = alc_lbl("bound", 0); + + n = proc->tree; + setloc(n); + if (Type(Tree1(n)) != N_Empty) { + /* + * initial clause. + */ + Tree1(n)->lifetime = NULL; + liveness(Tree1(n), NULL, &failer, &gen); + if (tfatals > 0) + return; + lbl = alc_lbl("end initial", 0); + cd_add(lbl); + cur_fnc->cursor = lbl->prev; /* code goes before label */ + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(1); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "!first_time"; + cd->Cond = cd1; + cd->ThenStmt = mk_goto(lbl); + cd_add(cd); + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "first_time = 0;"; + cd_add(cd); + bound(Tree1(n), &ignore, 1); + cur_fnc->cursor = lbl; + } + Tree2(n)->lifetime = NULL; + liveness(Tree2(n), NULL, &failer, &gen); + if (tfatals > 0) + return; + bound(Tree2(n), &ignore, 1); + + /* + * Place code to perform procedure failure and return and the + * end of the outer function. + */ + setloc(Tree3(n)); + cd_add(p_fail_lbl); + cd = NewCode(0); + cd->cd_id = C_PFail; + cd_add(cd); + cd_add(p_ret_lbl); + cd = NewCode(0); + cd->cd_id = C_PRet; + cd_add(cd); + + /* + * Fix up signal handling code and perform peephole optimizations. + */ + fix_fncs(fnc_lst); + +#ifdef OptimizeLit + analyze_literals(procstart, NULL, 0); + propagate_literals(); +#endif /* OptimizeLit */ + + /* + * The outer function is the first one on the list. It has the + * procedure interface; the others are just continuations. + */ + outerfnc(fnc_lst); + for (fnc = fnc_lst->next; fnc != NULL; fnc = fnc->next) + if (fnc->ref_cnt > 0) + prt_fnc(fnc); +#ifdef OptimizeLit + free_tbl(); +#endif /* OptimizeLit */ +} + +/* + * gencode - generate code for a syntax tree. + */ +static struct val_loc *gencode(n, rslt) +struct node *n; +struct val_loc *rslt; + { + struct code *cd; + struct code *cd1; + struct code *fail_sav; + struct code *lbl1; + struct code *lbl2; + struct code *cursor_sav; + struct c_fnc *fnc_sav; + struct c_fnc *fnc; + struct implement *impl; + struct implement *impl1; + struct val_loc *r1[3]; + struct val_loc *r2[2]; + struct val_loc *frst_arg; + struct lentry *single; + struct freetmp *freetmp; + struct freetmp *ft; + struct tmplftm *lifetm_ary; + char *sbuf; + int i; + int tmp_indx; + int nargs; + static struct loop_info *loop_info = NULL; + struct loop_info *li_sav; + + switch (n->n_type) { + case N_Activat: + rslt = gen_act(n, rslt); + break; + + case N_Alt: + rslt = chk_alc(rslt, n->lifetime); /* insure a result location */ + + fail_sav = on_failure; + fnc_sav = cur_fnc; + + /* + * If the first alternative fails, execution must go to the + * "alt" label. + */ + lbl1 = alc_lbl("alt", 0); + on_failure = lbl1; + + cd_add(lbl1); + cur_fnc->cursor = lbl1->prev; /* 1st alternative goes before label */ + gencode(Tree0(n), rslt); + + /* + * Each alternative must call the same success continuation. + */ + fnc = alc_fnc(); + callc_add(fnc); + + cur_fnc = fnc_sav; /* return to the context of the label */ + cur_fnc->cursor = lbl1; /* 2nd alternative goes after label */ + on_failure = fail_sav; /* on failure, alternation fails */ + gencode(Tree1(n), rslt); + callc_add(fnc); /* call continuation */ + + /* + * Code following the alternation goes in the continuation. If + * the code fails, the continuation returns the resume signal. + */ + cur_fnc = fnc; + on_failure = &resume; + break; + + case N_Apply: + rslt = gen_apply(n, rslt); + break; + + case N_Augop: + impl = Impl0(n); /* assignment */ + impl1 = Impl1(n); /* the operation */ + if (impl == NULL || impl1 == NULL) { + rslt = &ignore; /* make sure code generation can continue */ + break; + } + + /* + * allocate an argument list for the operation. + */ + lifetm_ary = alc_lftm(2, &n->n_field[2]); + tmp_indx = alc_tmp(2, lifetm_ary); + r1[0] = tmp_loc(tmp_indx); + r1[1] = tmp_loc(tmp_indx + 1); + + gencode(Tree2(n), r1[0]); /* first argument */ + + /* + * allocate an argument list for the assignment and copy the + * value of the first argument into it. + */ + lifetm_ary[0].cur_status = InUse; + lifetm_ary[1].cur_status = n->postn; + lifetm_ary[1].lifetime = n->intrnl_lftm; + tmp_indx = alc_tmp(2, lifetm_ary); + r2[0] = tmp_loc(tmp_indx++); + cd_add(mk_cpyval(r2[0], r1[0])); + r2[1] = tmp_loc(tmp_indx); + + gencode(Tree3(n), r1[1]); /* second argument */ + + /* + * Produce code for the operation. + */ + setloc(n); + implproto(impl1); + mk_callop(oper_name(impl1), impl1->ret_flag, r1[0], 2, r2[1], 0); + + /* + * Produce code for the assignment. + */ + implproto(impl); + if (impl->ret_flag & (DoesRet | DoesSusp)) + rslt = chk_alc(rslt, n->lifetime); + mk_callop(oper_name(impl), impl->ret_flag, r2[0], 2, rslt, 0); + + free((char *)lifetm_ary); + break; + + case N_Bar: { + struct val_loc *fail_flg; + + /* + * Allocate an integer variable to keep track of whether the + * repeated alternation should fail when execution reaches + * the top of its loop, and generate code to initialize the + * variable to 0. + */ + fail_flg = itmp_loc(alc_itmp(n->intrnl_lftm)); + cd = alc_ary(2); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = fail_flg; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = 0;"; + cd_add(cd); + + /* + * Code at the top of the repeated alternation loop checks + * the failure flag. + */ + lbl1 = alc_lbl("rep alt", 0); + cd_add(lbl1); + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(1); + cd1->ElemTyp(0) = A_ValLoc; + cd1->ValLoc(0) = fail_flg; + cd->Cond = cd1; + cd->ThenStmt = sig_cd(on_failure, cur_fnc); + cd_add(cd); + + /* + * If the expression fails without producing a value, the + * repeated alternation must fail. + */ + cd = alc_ary(2); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = fail_flg; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = 1;"; + cd_add(cd); + + /* + * Generate code for the repeated expression. If it produces + * a value before before backtracking occurs, the loop is + * repeated as indicated by the value of the failure flag. + */ + on_failure = lbl1; + rslt = gencode(Tree0(n), rslt); + cd = alc_ary(2); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = fail_flg; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = 0;"; + cd_add(cd); + } + break; + + case N_Break: + if (loop_info == NULL) { + nfatal(n, "invalid context for a break expression", NULL); + rslt = &ignore; + break; + } + + /* + * If the break is in a different string scanning context from the + * loop itself, generate code to restore the scanning environment. + */ + if (nxt_scan != loop_info->scan_info) + restr_env(loop_info->scan_info->outer_sub, + loop_info->scan_info->outer_pos); + + + if (Tree0(n)->n_type == N_Empty && loop_info->rslt == &ignore) { + /* + * The break has no associated expression and the loop needs + * no value, so just branch out of the loop. + */ + cd_add(sig_cd(loop_info->end_loop, cur_fnc)); + } + else { + /* + * The code for the expression associated with the break is + * actually placed at the end of the loop. Go there and + * add a label to branch to. + */ + cursor_sav = cur_fnc->cursor; + fnc_sav = cur_fnc; + fail_sav = on_failure; + cur_fnc = loop_info->end_loop->Container; + cur_fnc->cursor = loop_info->end_loop->prev; + on_failure = loop_info->on_failure; + lbl1 = alc_lbl("break", 0); + cd_add(lbl1); + + /* + * Make sure a result location has been allocated for the + * loop, restore the loop information for the next outer + * loop, generate code for the break expression, then + * restore the loop information for this loop. + */ + loop_info->rslt = chk_alc(loop_info->rslt, Tree0(n)->lifetime); + li_sav = loop_info; + loop_info = loop_info->prev; + gencode(Tree0(n), li_sav->rslt); + loop_info = li_sav; + + /* + * If this or another break expression suspends so we cannot + * just branch to the end of the loop, all breaks must + * call a common continuation. + */ + if (cur_fnc->cursor->next != loop_info->end_loop && + loop_info->succ_cont == NULL) + loop_info->succ_cont = alc_fnc(); + if (loop_info->succ_cont == NULL) + cd_add(mk_goto(loop_info->end_loop)); /* go to end of loop */ + else + callc_add(loop_info->succ_cont); /* call continuation */ + + /* + * Return to the location of the break and generate a branch to + * the code for its associated expression. + */ + cur_fnc = fnc_sav; + cur_fnc->cursor = cursor_sav; + on_failure = fail_sav; + cd_add(sig_cd(lbl1, cur_fnc)); + } + rslt = &ignore; /* shouldn't be used but must be something valid */ + break; + + case N_Case: + rslt = gen_case(n, rslt); + break; + + case N_Create: + rslt = gen_creat(n, rslt); + break; + + case N_Cset: + case N_Int: + case N_Real: + case N_Str: + cd = NewCode(2); + cd->cd_id = C_Lit; + rslt = chk_alc(rslt, n->lifetime); + cd->Rslt = rslt; + cd->Literal = CSym0(n); + cd_add(cd); + break; + + case N_Empty: + /* + * Assume null value is needed. + */ + if (rslt == &ignore) + break; + rslt = chk_alc(rslt, n->lifetime); + cd_add(asgn_null(rslt)); + break; + + case N_Field: + rslt = field_ref(n, rslt); + break; + + case N_Id: + /* + * If the variable reference is not going to be used, don't bother + * building it. + */ + if (rslt == &ignore) + break; + cd = NewCode(2); + cd->cd_id = C_NamedVar; + rslt = chk_alc(rslt, n->lifetime); + cd->Rslt = rslt; + cd->NamedVar = LSym0(n); + cd_add(cd); + break; + + case N_If: + if (Type(Tree2(n)) == N_Empty) { + /* + * if-then. Control clause is bounded, but otherwise trivial. + */ + bound(Tree0(n), &ignore, 0); /* control clause */ + rslt = gencode(Tree1(n), rslt); /* then clause */ + } + else { + /* + * if-then-else. Establish an "else" label as the failure + * label of the bounded control clause. + */ + fail_sav = on_failure; + fnc_sav = cur_fnc; + lbl1 = alc_lbl("else", 0); + on_failure = lbl1; + + bound(Tree0(n), &ignore, 0); /* control clause */ + + cd_add(lbl1); + cur_fnc->cursor = lbl1->prev; /* then clause goes before else lbl */ + on_failure = fail_sav; + rslt = chk_alc(rslt, n->lifetime); + gencode(Tree1(n), rslt); /* then clause */ + + /* + * If the then clause is not a generator, execution can + * just go to the end of the if-then-else expression. If it + * is a generator, the continuation for the expression must be + * in a separate function. + */ + if (cur_fnc->cursor->next == lbl1) { + fnc = NULL; + lbl2 = alc_lbl("end if", 0); + cd_add(mk_goto(lbl2)); + cur_fnc->cursor = lbl1; + cd_add(lbl2); + } + else { + lbl2 = NULL; + fnc = alc_fnc(); + callc_add(fnc); + cur_fnc = fnc_sav; + } + + cur_fnc->cursor = lbl1; /* else clause goes after label */ + on_failure = fail_sav; + gencode(Tree2(n), rslt); /* else clause */ + + /* + * If the else clause is not a generator, execution is at + * the end of the if-then-else expression, but the if clause + * may have forced the continuation to be in a separate function. + * If the else clause is a generator, it forces the continuation + * to be in a separate function. + */ + if (fnc == NULL) { + if (cur_fnc->cursor->next == lbl2) + cur_fnc->cursor = lbl2; + else { + fnc = alc_fnc(); + callc_add(fnc); + /* + * The then clause is not a generator, so it has branched + * to lbl2. We must add a call to the continuation there. + */ + cur_fnc = fnc_sav; + cur_fnc->cursor = lbl2; + on_failure = fail_sav; + callc_add(fnc); + } + } + else + callc_add(fnc); + + if (fnc != NULL) { + /* + * We produced a continuation for the if-then-else, so code + * generation must proceed in it. + */ + cur_fnc = fnc; + on_failure = &resume; + } + } + break; + + case N_Invok: + /* + * General invocation. + */ + nargs = Val0(n); + if (Tree1(n)->n_type == N_Empty) { + /* + * Mutual evaluation. + */ + for (i = 2; i <= nargs; ++i) + gencode(n->n_field[i].n_ptr, &ignore); /* arg i - 1 */ + rslt = chk_alc(rslt, n->lifetime); + gencode(n->n_field[nargs + 1].n_ptr, rslt); /* last argument */ + } + else { + ++nargs; /* consider the procedure an argument to invoke() */ + frst_arg = gen_args(n, 1, nargs); + setloc(n); + /* + * Assume this operation uses its result location as a work + * area. Give it a location that is tended, where the value + * is retained as long as the operation can be resumed. + */ + if (rslt == &ignore) + rslt = NULL; /* force allocation of temporary */ + rslt = chk_alc(rslt, max_lftm(n->lifetime, n->intrnl_lftm)); + mk_callop( "invoke", DoesRet | DoesFail | DoesSusp, frst_arg, nargs, + rslt, 0); + } + break; + + case N_InvOp: + rslt = inv_op(n, rslt); + break; + + case N_InvProc: + rslt = inv_prc(n, rslt); + break; + + case N_InvRec: { + /* + * Directly invoke a record constructor. + */ + struct rentry *rec; + + nargs = Val0(n); /* number of arguments */ + frst_arg = gen_args(n, 2, nargs); + setloc(n); + rec = Rec1(n); + + rslt = chk_alc(rslt, n->lifetime); + + /* + * If error conversion can occur then the record constructor may + * fail and we must check the signal. + */ + if (err_conv) { + sbuf = (char *)alloc((unsigned int)(strlen(rec->name) + + strlen("signal = R_") + PrfxSz + 1)); + sprintf(sbuf, "signal = R%s_%s(", rec->prefix, rec->name); + } + else { + sbuf = (char *)alloc((unsigned int)(strlen(rec->name) + PrfxSz +4)); + sprintf(sbuf, "R%s_%s(", rec->prefix, rec->name); + } + cd = alc_ary(9); + cd->ElemTyp(0) = A_Str; /* constructor name */ + cd->Str(0) = sbuf; + cd->ElemTyp(1) = A_Intgr; /* number of arguments */ + cd->Intgr(1) = nargs; + cd->ElemTyp(2) = A_Str; /* , */ + cd->Str(2) = ", "; + if (frst_arg == NULL) { /* location of first argument */ + cd->ElemTyp(3) = A_Str; + cd->Str(3) = "NULL"; + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ""; + } + else { + cd->ElemTyp(3) = A_Str; + cd->Str(3) = "&"; + cd->ElemTyp(4) = A_ValLoc; + cd->ValLoc(4) = frst_arg; + } + cd->ElemTyp(5) = A_Str; /* , */ + cd->Str(5) = ", "; + cd->ElemTyp(6) = A_Str; /* location of result */ + cd->Str(6) = "&"; + cd->ElemTyp(7) = A_ValLoc; + cd->ValLoc(7) = rslt; + cd->ElemTyp(8) = A_Str; + cd->Str(8) = ");"; + cd_add(cd); + if (err_conv) { + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(1); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "signal == A_Resume"; + cd->Cond = cd1; + cd->ThenStmt = sig_cd(on_failure, cur_fnc); + cd_add(cd); + } + } + break; + + case N_Limit: + rslt = gen_lim(n, rslt); + break; + + case N_Loop: { + struct loop_info li; + + /* + * Set up loop information for use by break and next expressions. + */ + li.end_loop = alc_lbl("end loop", 0); + cd_add(li.end_loop); + cur_fnc->cursor = li.end_loop->prev; /* loop goes before label */ + li.rslt = rslt; + li.on_failure = on_failure; + li.scan_info = nxt_scan; + li.succ_cont = NULL; + li.prev = loop_info; + loop_info = &li; + + switch ((int)Val0(Tree0(n))) { + case EVERY: + /* + * "next" in the control clause just fails. + */ + li.next_lbl = &next_fail; + gencode(Tree1(n), &ignore); /* control clause */ + /* + * "next" in the do clause transfers control to the + * statement at the end of the loop that resumes the + * control clause. + */ + li.next_lbl = alc_lbl("next", 0); + bound(Tree2(n), &ignore, 1); /* do clause */ + cd_add(li.next_lbl); + cd_add(sig_cd(on_failure, cur_fnc)); /* resume control clause */ + break; + + case REPEAT: + li.next_lbl = alc_lbl("repeat", 0); + cd_add(li.next_lbl); + bound(Tree1(n), &ignore, 1); + cd_add(mk_goto(li.next_lbl)); + break; + + case SUSPEND: /* suspension expression */ + if (create_lvl > 0) { + nfatal(n, "invalid context for suspend", NULL); + return &ignore; + } + /* + * "next" in the control clause just fails. The result + * of the control clause goes in the procedure return + * location. + */ + li.next_lbl = &next_fail; + genretval(n, Tree1(n), &proc_rslt); + + /* + * If necessary, swap scanning environments before suspending. + * if there is no success continuation, just return. + */ + if (nxt_scan != &scan_base) { + save_env(scan_base.inner_sub, scan_base.inner_pos); + restr_env(scan_base.outer_sub, scan_base.outer_pos); + } + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(2); + cd1->ElemTyp(0) = A_ProcCont; + cd1->ElemTyp(1) = A_Str; + cd1->Str(1) = " == NULL"; + cd->Cond = cd1; + cd->ThenStmt = sig_cd(p_ret_lbl, cur_fnc); + cd_add(cd); + cd = NewCode(0); + cd->cd_id = C_PSusp; + cd_add(cd); + cur_fnc->flag |= CF_ForeignSig; + + /* + * Force updating file name and line number, and if needed, + * switch scanning environments before resuming. + */ + lastfiln = NULL; + lastline = 0; + if (nxt_scan != &scan_base) { + save_env(scan_base.outer_sub, scan_base.outer_pos); + restr_env(scan_base.inner_sub, scan_base.inner_pos); + } + + /* + * "next" in the do clause transfers control to the + * statement at the end of the loop that resumes the + * control clause. + */ + li.next_lbl = alc_lbl("next", 0); + bound(Tree2(n), &ignore, 1); /* do clause */ + cd_add(li.next_lbl); + cd_add(sig_cd(on_failure, cur_fnc)); + break; + + case WHILE: + li.next_lbl = alc_lbl("while", 0); + cd_add(li.next_lbl); + /* + * The control clause and do clause are both bounded expressions, + * but only the do clause establishes a new failure label. + */ + bound(Tree1(n), &ignore, 0); /* control clause */ + bound(Tree2(n), &ignore, 1); /* do clause */ + cd_add(mk_goto(li.next_lbl)); + break; + + case UNTIL: + fail_sav = on_failure; + li.next_lbl = alc_lbl("until", 0); + cd_add(li.next_lbl); + + /* + * If the control clause fails, execution continues in + * the loop. + */ + if (Type(Tree2(n)) == N_Empty) + on_failure = li.next_lbl; + else { + lbl2 = alc_lbl("do", 0); + on_failure = lbl2; + cd_add(lbl2); + cur_fnc->cursor = lbl2->prev; /* control before label */ + } + bound(Tree1(n), &ignore, 0); /* control clause */ + + /* + * If the control clause succeeds, the loop fails. + */ + cd_add(sig_cd(fail_sav, cur_fnc)); + + if (Type(Tree2(n)) != N_Empty) { + /* + * Do clause goes after the label and the loop repeats. + */ + cur_fnc->cursor = lbl2; + bound(Tree2(n), &ignore, 1); /* do clause */ + cd_add(mk_goto(li.next_lbl)); + } + break; + } + + /* + * Go to the end of the loop and see if the loop's success continuation + * is in a separate function. + */ + cur_fnc = li.end_loop->Container; + cur_fnc->cursor = li.end_loop; + if (li.succ_cont != NULL) { + callc_add(li.succ_cont); + cur_fnc = li.succ_cont; + on_failure = &resume; + } + if (li.rslt == NULL) + rslt = &ignore; /* shouldn't be used but must be something valid */ + else + rslt = li.rslt; + loop_info = li.prev; + break; + } + + case N_Next: + /* + * In some contexts "next" just fails. In other contexts it + * transfers control to a label, in which case it may have + * to restore a scanning environment. + */ + if (loop_info == NULL) + nfatal(n, "invalid context for a next expression", NULL); + else if (loop_info->next_lbl == &next_fail) + cd_add(sig_cd(on_failure, cur_fnc)); + else { + if (nxt_scan != loop_info->scan_info) + restr_env(loop_info->scan_info->outer_sub, + loop_info->scan_info->outer_pos); + cd_add(sig_cd(loop_info->next_lbl, cur_fnc)); + } + rslt = &ignore; /* shouldn't be used but must be something valid */ + break; + + case N_Not: + lbl1 = alc_lbl("not", 0); + fail_sav = on_failure; + on_failure = lbl1; + cd_add(lbl1); + cur_fnc->cursor = lbl1->prev; /* code goes before label */ + bound(Tree0(n), &ignore, 0); + on_failure = fail_sav; + cd_add(sig_cd(on_failure, cur_fnc)); /* convert success to failure */ + cur_fnc->cursor = lbl1; /* convert failure to null */ + if (rslt != &ignore) { + rslt = chk_alc(rslt, n->lifetime); + cd_add(asgn_null(rslt)); + } + break; + + case N_Ret: + if (create_lvl > 0) { + nfatal(n, "invalid context for return or fail", NULL); + return &ignore; + } + if (Val0(Tree0(n)) == RETURN) { + /* + * Set up the failure action of the return expression to do a + * procedure fail. + */ + if (nxt_scan != &scan_base) { + /* + * we must switch scanning environments if the expression fails. + */ + lbl1 = alc_lbl("return fail", 0); + cd_add(lbl1); + restr_env(scan_base.outer_sub, scan_base.outer_pos); + cd_add(sig_cd(p_fail_lbl, cur_fnc)); + cur_fnc->cursor = lbl1->prev; /* code goes before label */ + on_failure = lbl1; + } + else + on_failure = p_fail_lbl; + + /* + * Produce code to place return value in procedure result location. + */ + genretval(n, Tree1(n), &proc_rslt); + + /* + * See if a scanning environment must be restored and + * transfer control to the procedure return code. + */ + if (nxt_scan != &scan_base) + restr_env(scan_base.outer_sub, scan_base.outer_pos); + cd_add(sig_cd(p_ret_lbl, cur_fnc)); + } + else { + /* + * fail. See if a scanning environment must be restored and + * transfer control to the procedure failure code. + */ + if (nxt_scan != &scan_base) + restr_env(scan_base.outer_sub, scan_base.outer_pos); + cd_add(sig_cd(p_fail_lbl, cur_fnc)); + } + rslt = &ignore; /* shouldn't be used but must be something valid */ + break; + + case N_Scan: + rslt = gen_scan(n, rslt); + break; + + case N_Sect: + /* + * x[i+:j] or x[i-:j] (x[i:j] handled as ordinary operator) + */ + impl1 = Impl0(n); /* sectioning */ + if (impl1 == NULL) { + rslt = &ignore; /* make sure code generation can continue */ + break; + } + implproto(impl1); + + impl = Impl1(n); /* plus or minus */ + /* + * Allocate work area of temporary variables for sectioning. + */ + lifetm_ary = alc_lftm(3, NULL); + lifetm_ary[0].cur_status = Tree2(n)->postn; + lifetm_ary[0].lifetime = n->intrnl_lftm; + lifetm_ary[1].cur_status = Tree3(n)->postn; + lifetm_ary[1].lifetime = n->intrnl_lftm; + lifetm_ary[2].cur_status = n->postn; + lifetm_ary[2].lifetime = n->intrnl_lftm; + tmp_indx = alc_tmp(3, lifetm_ary); + for (i = 0; i < 3; ++i) + r1[i] = tmp_loc(tmp_indx++); + gencode(Tree2(n), r1[0]); /* generate code to compute x */ + gencode(Tree3(n), r1[1]); /* generate code compute i */ + + /* + * Allocate work area of temporary variables for arithmetic. + */ + lifetm_ary[0].cur_status = InUse; + lifetm_ary[0].lifetime = Tree3(n)->lifetime; + lifetm_ary[1].cur_status = Tree4(n)->postn; + lifetm_ary[1].lifetime = Tree4(n)->lifetime; + tmp_indx = alc_tmp(2, lifetm_ary); + for (i = 0; i < 2; ++i) + r2[i] = tmp_loc(tmp_indx++); + cd_add(mk_cpyval(r2[0], r1[1])); /* generate code to copy i */ + gencode(Tree4(n), r2[1]); /* generate code to compute j */ + + /* + * generate code for i op j. + */ + setloc(n); + implproto(impl); + mk_callop(oper_name(impl), impl->ret_flag, r2[0], 2, r1[2], 0); + + /* + * generate code for x[i : (i op j)] + */ + rslt = chk_alc(rslt, n->lifetime); + mk_callop(oper_name(impl1),impl1->ret_flag,r1[0],3,rslt,0); + free((char *)lifetm_ary); + break; + + case N_Slist: + bound(Tree0(n), &ignore, 1); + rslt = gencode(Tree1(n), rslt); + break; + + case N_SmplAsgn: { + struct val_loc *var, *val; + + /* + * Optimized assignment to a named variable. Use information + * from type inferencing to determine if the right-hand-side + * is a variable. + */ + var = var_ref(LSym0(Tree2(n))); + if (HasVar(varsubtyp(Tree3(n)->type, &single))) + Val0(n) = AsgnDeref; + if (single != NULL) { + /* + * Right-hand-side results in a named variable. Compute + * the expression but don't bother saving the result, we + * know what it is. Assignment just copies value from + * one variable to the other. + */ + gencode(Tree3(n), &ignore); + val = var_ref(single); + cd_add(mk_cpyval(var, val)); + } + else switch (Val0(n)) { + case AsgnDirect: + /* + * It is safe to compute the result directly into the variable. + */ + gencode(Tree3(n), var); + break; + case AsgnCopy: + /* + * The result is not a variable reference, but it is not + * safe to compute it into the variable, we must use a + * temporary variable. + */ + val = gencode(Tree3(n), NULL); + cd_add(mk_cpyval(var, val)); + break; + case AsgnDeref: + /* + * We must dereference the result into the variable. + */ + val = gencode(Tree3(n), NULL); + deref_cd(val, var); + break; + } + + /* + * If the assignment has to produce a result, construct the + * variable reference. + */ + if (rslt != &ignore) + rslt = gencode(Tree2(n), rslt); + } + break; + + case N_SmplAug: { + /* + * Optimized augmented assignment to a named variable. + */ + struct val_loc *var, *val; + + impl = Impl1(n); /* the operation */ + if (impl == NULL) { + rslt = &ignore; /* make sure code generation can continue */ + break; + } + + implproto(impl); /* insure prototype for operation */ + + /* + * Generate code to compute the arguments for the operation. + */ + frst_arg = gen_args(n, 2, 2); + setloc(n); + + /* + * Use information from type inferencing to determine if the + * operation produces a variable. + */ + if (HasVar(varsubtyp(Typ4(n), &single))) + Val0(n) = AsgnDeref; + var = var_ref(LSym0(Tree2(n))); + if (single != NULL) { + /* + * The operation results in a named variable. Call the operation + * but don't bother saving the result, we know what it is. + * Assignment just copies value from one variable to the other. + */ + mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, + &ignore, 0); + val = var_ref(single); + cd_add(mk_cpyval(var, val)); + } + else switch (Val0(n)) { + case AsgnDirect: + /* + * It is safe to compute the result directly into the variable. + */ + mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, + var, 0); + break; + case AsgnCopy: + /* + * The result is not a variable reference, but it is not + * safe to compute it into the variable, we must use a + * temporary variable. + */ + val = chk_alc(NULL, n); + mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, val, 0); + cd_add(mk_cpyval(var, val)); + break; + case AsgnDeref: + /* + * We must dereference the result into the variable. + */ + val = chk_alc(NULL, n); + mk_callop(oper_name(impl), impl->ret_flag, frst_arg, 2, val, 0); + deref_cd(val, var); + break; + } + + /* + * If the assignment has to produce a result, construct the + * variable reference. + */ + if (rslt != &ignore) + rslt = gencode(Tree2(n), rslt); + } + break; + + default: + fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); + exit(EXIT_FAILURE); + } + + /* + * Free any temporaries whose lifetime ends at this node. + */ + freetmp = n->freetmp; + while (freetmp != NULL) { + switch (freetmp->kind) { + case DescTmp: + tmp_status[freetmp->indx] = freetmp->old; + break; + case CIntTmp: + itmp_status[freetmp->indx] = freetmp->old; + break; + case CDblTmp: + dtmp_status[freetmp->indx] = freetmp->old; + break; + case SBuf: + sbuf_status[freetmp->indx] = freetmp->old; + break; + case CBuf: + cbuf_status[freetmp->indx] = freetmp->old; + break; + } + ft = freetmp->next; + freetmp->next = freetmp_pool; + freetmp_pool = freetmp; + freetmp = ft; + } + return rslt; + } + +/* + * chk_alc - make sure a result location has been allocated. If it is + * a temporary variable, indicate that it is now in use. + */ +struct val_loc *chk_alc(rslt, lifetime) +struct val_loc *rslt; +nodeptr lifetime; + { + struct tmplftm tmplftm; + + if (rslt == NULL) { + if (lifetime == NULL) + rslt = &ignore; + else { + tmplftm.cur_status = InUse; + tmplftm.lifetime = lifetime; + rslt = tmp_loc(alc_tmp(1, &tmplftm)); + } + } + else if (rslt->loc_type == V_Temp) + tmp_status[rslt->u.tmp] = InUse; + return rslt; + } + +/* + * mk_goto - make a code structure for goto label + */ +struct code *mk_goto(label) +struct code *label; + { + register struct code *cd; + + cd = NewCode(1); /* # fields == # fields of C_RetSig & C_Break */ + cd->cd_id = C_Goto; + cd->next = NULL; + cd->prev = NULL; + cd->Lbl = label; + ++label->RefCnt; + return cd; + } + +/* + * mk_cpyval - make code to copy a value from one location to another. + */ +static struct code *mk_cpyval(loc1, loc2) +struct val_loc *loc1; +struct val_loc *loc2; + { + struct code *cd; + + cd = alc_ary(4); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = loc1; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = "; + cd->ElemTyp(2) = A_ValLoc; + cd->ValLoc(2) = loc2; + cd->ElemTyp(3) = A_Str; + cd->Str(3) = ";"; + return cd; + } + +/* + * asgn_null - make code to assign the null value to a location. + */ +static struct code *asgn_null(loc1) +struct val_loc *loc1; + { + struct code *cd; + + cd = alc_ary(2); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = loc1; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = nulldesc;"; + return cd; + } + +/* + * oper_name - create the name for the most general implementation of an Icon + * operation. + */ +static char *oper_name(impl) +struct implement *impl; + { + char *sbuf; + + sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); + sprintf(sbuf, "%c%c%c_%s", impl->oper_typ, impl->prefix[0], impl->prefix[1], + impl->name); + return sbuf; + } + +/* + * gen_args - generate code to evaluate an argument list. + */ +static struct val_loc *gen_args(n, frst_arg, nargs) +struct node *n; +int frst_arg; +int nargs; + { + struct tmplftm *lifetm_ary; + int i; + int tmp_indx; + + if (nargs == 0) + return NULL; + + lifetm_ary = alc_lftm(nargs, &n->n_field[frst_arg]); + tmp_indx = alc_tmp(nargs, lifetm_ary); + for (i = 0; i < nargs; ++i) + gencode(n->n_field[frst_arg + i].n_ptr, tmp_loc(tmp_indx + i)); + free((char *)lifetm_ary); + return tmp_loc(tmp_indx); + } + +/* + * gen_case - generate code for a case expression. + */ +static struct val_loc *gen_case(n, rslt) +struct node *n; +struct val_loc *rslt; + { + struct node *control; + struct node *cases; + struct node *deflt; + struct node *clause; + struct val_loc *r1; + struct val_loc *r2; + struct val_loc *r3; + struct code *cd; + struct code *cd1; + struct code *fail_sav; + struct code *skp_lbl; + struct code *cd_lbl; + struct code *end_lbl; + struct c_fnc *fnc_sav; + struct c_fnc *succ_cont = NULL; + + control = Tree0(n); + cases = Tree1(n); + deflt = Tree2(n); + + /* + * The control clause is bounded. + */ + r1 = chk_alc(NULL, n); + bound(control, r1, 0); + + /* + * Remember the context in which the case expression occurs and + * establish a label at the end of the expression. + */ + fail_sav = on_failure; + fnc_sav = cur_fnc; + end_lbl = alc_lbl("end case", 0); + cd_add(end_lbl); + cur_fnc->cursor = end_lbl->prev; /* generate code before the end label */ + + /* + * All cases share the result location of the case expression. + */ + rslt = chk_alc(rslt, n->lifetime); + r2 = chk_alc(NULL, n); /* for result of selection clause */ + r3 = chk_alc(NULL, n); /* for dereferenced result of control clause */ + + while (cases != NULL) { + /* + * See if we are at the end of the case clause list. + */ + if (cases->n_type == N_Ccls) { + clause = cases; + cases = NULL; + } + else { + clause = Tree1(cases); + cases = Tree0(cases); + } + + /* + * If the evaluation of the selection code or the comparison of + * its value to the control clause fail, execution will proceed + * to the "skip clause" label and on to the next case. + */ + skp_lbl = alc_lbl("skip clause", 0); + on_failure = skp_lbl; + cd_add(skp_lbl); + cur_fnc->cursor = skp_lbl->prev; /* generate code before end label */ + + /* + * Bound the selection code for this clause. + */ + cd_lbl = alc_lbl("selected code", Bounding); + cd_add(cd_lbl); + cur_fnc->cursor = cd_lbl->prev; + gencode(Tree0(clause), r2); + + /* + * Dereference the results of the control clause and the selection + * clause and compare them. + */ + setloc(clause); + deref_cd(r1, r3); + deref_cd(r2, r2); + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(5); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "!equiv(&"; + cd1->ElemTyp(1) = A_ValLoc; + cd1->ValLoc(1) = r3; + cd->Cond = cd1; + cd1->ElemTyp(2) = A_Str; + cd1->Str(2) = ", &"; + cd1->ElemTyp(3) = A_ValLoc; + cd1->ValLoc(3) = r2; + cd1->ElemTyp(4) = A_Str; + cd1->Str(4) = ")"; + cd->ThenStmt = sig_cd(on_failure, cur_fnc); + cd_add(cd); + cd_add(sig_cd(cd_lbl, cur_fnc)); /* transfer control to bounding label */ + + /* + * Generate code for the body of this clause after the bounding label. + */ + cur_fnc = fnc_sav; + cur_fnc->cursor = cd_lbl; + on_failure = fail_sav; + gencode(Tree1(clause), rslt); + + /* + * If this clause is a generator, call the success continuation + * for the case expression, otherwise branch to the end of the + * expression. + */ + if (cur_fnc->cursor->next != skp_lbl) { + if (succ_cont == NULL) + succ_cont = alc_fnc(); /* allocate a continuation function */ + callc_add(succ_cont); + cur_fnc = fnc_sav; + } + else + cd_add(mk_goto(end_lbl)); + + /* + * The code for the next clause goes after the "skip" label of + * this clause. + */ + cur_fnc->cursor = skp_lbl; + } + + if (deflt == NULL) + cd_add(sig_cd(fail_sav, cur_fnc)); /* default action is failure */ + else { + /* + * There is an explicit default action. + */ + on_failure = fail_sav; + gencode(deflt, rslt); + if (cur_fnc->cursor->next != end_lbl) { + if (succ_cont == NULL) + succ_cont = alc_fnc(); + callc_add(succ_cont); + cur_fnc = fnc_sav; + } + } + cur_fnc->cursor = end_lbl; + + /* + * If some clauses are generators but others have transferred control + * to here, we must call the success continuation of the case + * expression and generate subsequent code there. + */ + if (succ_cont != NULL) { + on_failure = fail_sav; + callc_add(succ_cont); + cur_fnc = succ_cont; + on_failure = &resume; + } + return rslt; + } + +/* + * gen_creat - generate code to create a co-expression. + */ +static struct val_loc *gen_creat(n, rslt) +struct node *n; +struct val_loc *rslt; + { + struct code *cd; + struct code *fail_sav; + struct code *fail_lbl; + struct c_fnc *fnc_sav; + struct c_fnc *fnc; + struct val_loc *co_rslt; + struct freetmp *ft; + char sav_prfx[PrfxSz]; + int *tmp_sv; + int *itmp_sv; + int *dtmp_sv; + int *sbuf_sv; + int *cbuf_sv; + int ntmp_sv; + int nitmp_sv; + int ndtmp_sv; + int nsbuf_sv; + int ncbuf_sv; + int stat_sz_sv; + int istat_sz_sv; + int dstat_sz_sv; + int sstat_sz_sv; + int cstat_sz_sv; + int i; + + + rslt = chk_alc(rslt, n->lifetime); + + fail_sav = on_failure; + fnc_sav = cur_fnc; + for (i = 0; i < PrfxSz; ++i) + sav_prfx[i] = frm_prfx[i]; + + /* + * Temporary variables are allocated independently for the co-expression. + */ + tmp_sv = tmp_status; + itmp_sv = itmp_status; + dtmp_sv = dtmp_status; + sbuf_sv = sbuf_status; + cbuf_sv = cbuf_status; + stat_sz_sv = status_sz; + istat_sz_sv = istatus_sz; + dstat_sz_sv = dstatus_sz; + sstat_sz_sv = sstatus_sz; + cstat_sz_sv = cstatus_sz; + ntmp_sv = num_tmp; + nitmp_sv = num_itmp; + ndtmp_sv = num_dtmp; + nsbuf_sv = num_sbuf; + ncbuf_sv = num_cbuf; + tmp_status = (int *)alloc((unsigned int)(status_sz * sizeof(int))); + itmp_status = (int *)alloc((unsigned int)(istatus_sz * sizeof(int))); + dtmp_status = (int *)alloc((unsigned int)(dstatus_sz * sizeof(int))); + sbuf_status = (int *)alloc((unsigned int)(sstatus_sz * sizeof(int))); + cbuf_status = (int *)alloc((unsigned int)(cstatus_sz * sizeof(int))); + for (i = 0; i < status_sz; ++i) + tmp_status[i] = NotAlloc; + for (i = 0; i < istatus_sz; ++i) + itmp_status[i] = NotAlloc; + for (i = 0; i < dstatus_sz; ++i) + dtmp_status[i] = NotAlloc; + for (i = 0; i < sstatus_sz; ++i) + sbuf_status[i] = NotAlloc; + for (i = 0; i < cstatus_sz; ++i) + cbuf_status[i] = NotAlloc; + num_tmp = 0; + num_itmp = 0; + num_dtmp = 0; + num_sbuf = 0; + num_cbuf = 0; + + /* + * Put code for co-expression in separate function. We will need a new + * type of procedure frame which contains copies of local variables, + * copies of arguments, and temporaries for use by the co-expression. + */ + fnc = alc_fnc(); + fnc->ref_cnt = 1; + fnc->flag |= CF_Coexpr; + ChkPrefix(fnc->prefix); + for (i = 0; i < PrfxSz; ++i) + frm_prfx[i] = fnc->frm_prfx[i] = fnc->prefix[i]; + cur_fnc = fnc; + + /* + * Set up a co-expression failure label followed by a context switch + * and a branch back to the failure label. + */ + fail_lbl = alc_lbl("co_fail", 0); + cd_add(fail_lbl); + lastline = 0; /* force setting line number so tracing matches interp */ + setloc(n); + cd = alc_ary(2); + cd->ElemTyp(0) = A_Str; + cd->ElemTyp(1) = A_Str; + cd->Str(0) = "co_chng(popact((struct b_coexpr *)BlkLoc(k_current)),"; + cd->Str(1) = "NULL, NULL, A_Cofail, 1);"; + cd_add(cd); + cd_add(mk_goto(fail_lbl)); + cur_fnc->cursor = fail_lbl->prev; /* code goes before failure label */ + on_failure = fail_lbl; + + /* + * Generate code for the co-expression body, using the same + * dereferencing rules as for procedure return. + */ + lastfiln = ""; /* force setting of file name and line number */ + lastline = 0; + setloc(n); + ++create_lvl; + co_rslt = genretval(n, Tree0(n), NULL); + --create_lvl; + + /* + * If the co-expression might produce a result, generate a co-expression + * context switch. + */ + if (co_rslt != NULL) { + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "++BlkLoc(k_current)->coexpr.size;"; + cd_add(cd); + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "co_chng(popact((struct b_coexpr *)BlkLoc(k_current)), &"; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = co_rslt; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ", NULL, A_Coret, 1);"; + cd_add(cd); + cd_add(sig_cd(on_failure, cur_fnc)); /* if reactivated, resume expr */ + } + + /* + * Output the new frame definition. + */ + prt_frame(frm_prfx, cur_proc->tnd_loc + num_tmp + Abs(cur_proc->nargs), + num_itmp, num_dtmp, num_sbuf, num_cbuf); + + /* + * Now return to original function and produce code to create the + * co-expression. + */ + cur_fnc = fnc_sav; + for (i = 0; i < PrfxSz; ++i) + frm_prfx[i] = sav_prfx[i]; + on_failure = fail_sav; + + lastfiln = ""; /* force setting of file name and line number */ + lastline = 0; + setloc(n); + cd = NewCode(5); + cd->cd_id = C_Create; + cd->Rslt = rslt; + cd->Cont = fnc; + cd->NTemps = num_tmp; + cd->WrkSize = num_itmp; + cd->NextCreat = cur_fnc->creatlst; + cur_fnc->creatlst = cd; + cd_add(cd); + + /* + * Restore arrays for temporary variable allocation. + */ + free((char *)tmp_status); + free((char *)itmp_status); + free((char *)dtmp_status); + free((char *)sbuf_status); + free((char *)cbuf_status); + tmp_status = tmp_sv; + itmp_status = itmp_sv; + dtmp_status = dtmp_sv; + sbuf_status = sbuf_sv; + cbuf_status = cbuf_sv; + status_sz = stat_sz_sv; + istatus_sz = istat_sz_sv; + dstatus_sz = dstat_sz_sv; + sstatus_sz = sstat_sz_sv; + cstatus_sz = cstat_sz_sv; + num_tmp = ntmp_sv; + num_itmp = nitmp_sv; + num_dtmp = ndtmp_sv; + num_sbuf = nsbuf_sv; + num_cbuf = ncbuf_sv; + + /* + * Temporary variables that exist to the end of the co-expression + * have no meaning in the surrounding code and must not be + * deallocated there. + */ + while (n->freetmp != NULL) { + ft = n->freetmp->next; + n->freetmp->next = freetmp_pool; + freetmp_pool = n->freetmp; + n->freetmp = ft; + } + + return rslt; + } + +/* + * gen_lim - generate code for limitation. + */ +static struct val_loc *gen_lim(n, rslt) +struct node *n; +struct val_loc *rslt; + { + struct node *expr; + struct node *limit; + struct val_loc *lim_desc; + struct code *cd; + struct code *cd1; + struct code *lbl; + struct code *fail_sav; + struct c_fnc *fnc_sav; + struct c_fnc *succ_cont; + struct val_loc *lim_int; + struct lentry *single; + int deref; + + expr = Tree0(n); + limit = Tree1(n); + + /* + * Generate code to compute the limitation value and dereference it. + */ + deref = HasVar(varsubtyp(limit->type, &single)); + if (single != NULL) { + /* + * Limitation is in a named variable. Use value directly from + * the variable rather than saving the result of the expression. + */ + gencode(limit, &ignore); + lim_desc = var_ref(single); + } + else { + lim_desc = gencode(limit, NULL); + if (deref) + deref_cd(lim_desc, lim_desc); + } + + setloc(n); + fail_sav = on_failure; + + /* + * Try to convert the limitation value into an integer. + */ + lim_int = itmp_loc(alc_itmp(n->intrnl_lftm)); + cur_symtyps = n->symtyps; + if (largeints || (eval_is(int_typ, 0) & MaybeFalse)) { + /* + * Must call the conversion routine. + */ + lbl = alc_lbl("limit is int", 0); + cd_add(lbl); + cur_fnc->cursor = lbl->prev; /* conversion goes before label */ + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(5); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "cnv_c_int(&"; + cd1->ElemTyp(1) = A_ValLoc; + cd1->ValLoc(1) = lim_desc; + cd1->ElemTyp(2) = A_Str; + cd1->Str(2) = ", &"; + cd1->ElemTyp(3) = A_ValLoc; + cd1->ValLoc(3) = lim_int; + cd1->ElemTyp(4) = A_Str; + cd1->Str(4) = ")"; + cd->Cond = cd1; + cd->ThenStmt = mk_goto(lbl); + cd_add(cd); + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "err_msg(101, &"; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = lim_desc; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ");"; + cd_add(cd); + if (err_conv) + cd_add(sig_cd(on_failure, cur_fnc)); + cur_fnc->cursor = lbl; + } + else { + /* + * The C integer is in the vword. + */ + cd = alc_ary(4); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = lim_int; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = IntVal("; + cd->ElemTyp(2) = A_ValLoc; + cd->ValLoc(2) = lim_desc; + cd->ElemTyp(3) = A_Str; + cd->Str(3) = ");"; + cd_add(cd); + } + + /* + * Make sure the limitation value is positive. + */ + lbl = alc_lbl("limit positive", 0); + cd_add(lbl); + cur_fnc->cursor = lbl->prev; /* code goes before label */ + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(2); + cd1->ElemTyp(0) = A_ValLoc; + cd1->ValLoc(0) = lim_int; + cd1->ElemTyp(1) = A_Str; + cd1->Str(1) = " >= 0"; + cd->Cond = cd1; + cd->ThenStmt = mk_goto(lbl); + cd_add(cd); + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "err_msg(205, &"; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = lim_desc; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ");"; + cd_add(cd); + if (err_conv) + cd_add(sig_cd(on_failure, cur_fnc)); + cur_fnc->cursor = lbl; + + /* + * If the limitation value is 0, fail immediately. + */ + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(2); + cd1->ElemTyp(0) = A_ValLoc; + cd1->ValLoc(0) = lim_int; + cd1->ElemTyp(1) = A_Str; + cd1->Str(1) = " == 0"; + cd->Cond = cd1; + cd->ThenStmt = sig_cd(on_failure, cur_fnc); + cd_add(cd); + + /* + * Establish where to go when limit has been reached. + */ + fnc_sav = cur_fnc; + lbl = alc_lbl("limit", 0); + cd_add(lbl); + cur_fnc->cursor = lbl->prev; /* limited expression goes before label */ + + /* + * Generate code for limited expression and to check the limit value. + */ + rslt = gencode(expr, rslt); + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(3); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "--"; + cd1->ElemTyp(1) = A_ValLoc; + cd1->ValLoc(1) = lim_int; + cd1->ElemTyp(2) = A_Str; + cd1->Str(2) = " == 0"; + cd->Cond = cd1; + cd->ThenStmt = sig_cd(lbl, cur_fnc); + cd_add(cd); + + /* + * Call the success continuation both here and after the limitation + * label. + */ + succ_cont = alc_fnc(); + callc_add(succ_cont); + cur_fnc = fnc_sav; + cur_fnc->cursor = lbl; + on_failure = fail_sav; + callc_add(succ_cont); + cur_fnc = succ_cont; + on_failure = &resume; + + return rslt; + } + +/* + * gen_apply - generate code for the apply operator, !. + */ +static struct val_loc *gen_apply(n, rslt) +struct node *n; +struct val_loc *rslt; + { + struct val_loc *callee; + struct val_loc *lst; + struct code *arg_lst; + struct code *on_ret; + struct c_fnc *fnc; + + /* + * Generate code to compute the two operands. + */ + callee = gencode(Tree0(n), NULL); + lst = gencode(Tree1(n), NULL); + rslt = chk_alc(rslt, n->lifetime); + setloc(n); + + /* + * Construct argument list for apply(). + */ + arg_lst = alc_ary(6); + arg_lst->ElemTyp(0) = A_Str; + arg_lst->Str(0) = "&"; + arg_lst->ElemTyp(1) = A_ValLoc; + arg_lst->ValLoc(1) = callee; + arg_lst->ElemTyp(2) = A_Str; + arg_lst->Str(2) = ", &"; + arg_lst->ElemTyp(3) = A_ValLoc; + arg_lst->ValLoc(3) = lst; + arg_lst->ElemTyp(4) = A_Str; + arg_lst->Str(4) = ", &"; + arg_lst->ElemTyp(5) = A_ValLoc; + arg_lst->ValLoc(5) = rslt; + + /* + * Generate code to call apply(). Assume the operation can suspend and + * allocate a continuation. If it returns a "continue" signal, + * just break out of the signal handling code and fall into a call + * to the continuation. + */ + on_ret = NewCode(1); /* #fields for C_Break == #fields for C_Goto */ + on_ret->cd_id = C_Break; + on_ret->next = NULL; + on_ret->prev = NULL; + fnc = alc_fnc(); /* success continuation */ + callo_add("apply", DoesFail | DoesRet | DoesSusp, fnc, 1, arg_lst, on_ret); + callc_add(fnc); + cur_fnc = fnc; /* subsequent code goes in the continuation */ + on_failure = &resume; + + return rslt; + } + + +/* + * gen_scan - generate code for string scanning. + */ +static struct val_loc *gen_scan(n, rslt) +nodeptr n; +struct val_loc *rslt; + { + struct node *op; + struct node *subj; + struct node *body; + struct scan_info *scanp; + struct val_loc *asgn_var; + struct val_loc *new_subj; + struct val_loc *scan_rslt; + struct tmplftm *lifetm_ary; + struct lentry *subj_single; + struct lentry *body_single; + struct code *cd; + struct code *cd1; + struct code *lbl; + struct implement *impl; + int subj_deref; + int body_deref; + int op_tok; + int tmp_indx; + + op = Tree0(n); /* operator node '?' or '?:=' */ + subj = Tree1(n); /* subject expression */ + body = Tree2(n); /* scanning expression */ + op_tok = optab[Val0(op)].tok.t_type; + + /* + * The location of the save areas for scanning environments is stored + * in list so they can be accessed by expressions that transfer + * control out of string scanning. Get the next list element and + * allocate the save areas in the procedure frame. + */ + scanp = nxt_scan; + if (nxt_scan->next == NULL) + nxt_scan->next = NewStruct(scan_info); + nxt_scan = nxt_scan->next; + scanp->outer_sub = chk_alc(NULL, n->intrnl_lftm); + scanp->outer_pos = itmp_loc(alc_itmp(n->intrnl_lftm)); + scanp->inner_sub = chk_alc(NULL, n->intrnl_lftm); + scanp->inner_pos = itmp_loc(alc_itmp(n->intrnl_lftm)); + + subj_deref = HasVar(varsubtyp(subj->type, &subj_single)); + if (subj_single != NULL) { + /* + * The subject value is in a named variable. Use value directly from + * the variable rather than saving the result of the expression. + */ + gencode(subj, &ignore); + new_subj = var_ref(subj_single); + + if (op_tok == AUGQMARK) { + body_deref = HasVar(varsubtyp(body->type, &body_single)); + if (body_single != NULL) + scan_rslt = &ignore; /* we know where the value will be */ + else + scan_rslt = chk_alc(NULL, n->intrnl_lftm); + } + else + scan_rslt = rslt; /* result of 2nd operand is result of scanning */ + } + else if (op_tok == AUGQMARK) { + /* + * Augmented string scanning using general assignment. The operands + * must be in consecutive locations. + */ + lifetm_ary = alc_lftm(2, &n->n_field[1]); + tmp_indx = alc_tmp(2, lifetm_ary); + asgn_var = tmp_loc(tmp_indx++); + scan_rslt = tmp_loc(tmp_indx); + free((char *)lifetm_ary); + + gencode(subj, asgn_var); + new_subj = chk_alc(NULL, n->intrnl_lftm); + deref_cd(asgn_var, new_subj); + } + else { + new_subj = gencode(subj, NULL); + if (subj_deref) + deref_cd(new_subj, new_subj); + scan_rslt = rslt; /* result of 2nd operand is result of scanning */ + } + + /* + * Produce code to save the old scanning environment. + */ + setloc(op); + save_env(scanp->outer_sub, scanp->outer_pos); + + /* + * Produce code to handle failure of the body of string scanning. + */ + lbl = alc_lbl("scan fail", 0); + cd_add(lbl); + restr_env(scanp->outer_sub, scanp->outer_pos); + cd_add(sig_cd(on_failure, cur_fnc)); /* fail */ + cur_fnc->cursor = lbl->prev; /* body goes before label */ + on_failure = lbl; + + /* + * If necessary, try to convert the subject to a string. Note that if + * error conversion occurs, backtracking will restore old subject. + */ + cur_symtyps = n->symtyps; + if (eval_is(str_typ, 0) & MaybeFalse) { + lbl = alc_lbl("&subject is string", 0); + cd_add(lbl); + cur_fnc->cursor = lbl->prev; /* code goes before label */ + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(3); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "cnv_str(&"; + cd1->ElemTyp(1) = A_ValLoc; + cd1->ValLoc(1) = new_subj; + cd1->ElemTyp(2) = A_Str; + cd1->Str(2) = ", &k_subject)"; + cd->Cond = cd1; + cd->ThenStmt = mk_goto(lbl); + cd_add(cd); + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "err_msg(103, &"; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = new_subj; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ");"; + cd_add(cd); + if (err_conv) + cd_add(sig_cd(on_failure, cur_fnc)); + cur_fnc->cursor = lbl; + } + else { + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "k_subject = "; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = new_subj; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ";"; + cd_add(cd); + } + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "k_pos = 1;"; + cd_add(cd); + + scan_rslt = gencode(body, scan_rslt); + + setloc(op); + if (op_tok == AUGQMARK) { + /* + * '?:=' - perform assignment. + */ + if (subj_single != NULL) { + /* + * Assignment to a named variable. + */ + if (body_single != NULL) + cd_add(mk_cpyval(new_subj, var_ref(body_single))); + else if (body_deref) + deref_cd(scan_rslt, new_subj); + else + cd_add(mk_cpyval(new_subj, scan_rslt)); + } + else { + /* + * Use general assignment. + */ + impl = optab[asgn_loc].binary; + if (impl == NULL) { + nfatal(op, "assignment not implemented", NULL); + rslt = &ignore; /* make sure code generation can continue */ + } + else { + implproto(impl); + rslt = chk_alc(rslt, n->lifetime); + mk_callop(oper_name(impl), impl->ret_flag, asgn_var, 2, rslt,0); + } + } + } + else { + /* + * '?' + */ + rslt = scan_rslt; + } + + /* + * Produce code restore subject and pos when the body of the + * scanning expression succeeds. The new subject and pos must + * be saved in case of resumption. + */ + save_env(scanp->inner_sub, scanp->inner_pos); + restr_env(scanp->outer_sub, scanp->outer_pos); + + /* + * Produce code to handle resumption of string scanning. + */ + lbl = alc_lbl("scan resume", 0); + cd_add(lbl); + save_env(scanp->outer_sub, scanp->outer_pos); + restr_env(scanp->inner_sub, scanp->inner_pos); + cd_add(sig_cd(on_failure, cur_fnc)); /* fail */ + cur_fnc->cursor = lbl->prev; /* success continuation goes before label */ + on_failure = lbl; + + nxt_scan = scanp; + return rslt; + } + +/* + * gen_act - generate code for co-expression activation. + */ +static struct val_loc *gen_act(n, rslt) +nodeptr n; +struct val_loc *rslt; + { + struct node *op; + struct node *transmit; + struct node *coexpr; + struct tmplftm *lifetm_ary; + struct val_loc *trans_loc; + struct val_loc *coexpr_loc; + struct val_loc *asgn1; + struct val_loc *asgn2; + struct val_loc *act_rslt; + struct lentry *c_single; + struct code *cd; + struct code *cd1; + struct code *lbl; + struct implement *impl; + int c_deref; + int op_tok; + int tmp_indx; + + op = Tree0(n); /* operator node for '@' or '@:=' */ + transmit = Tree1(n); /* expression for value to transmit */ + coexpr = Tree2(n); /* expression for co-expression */ + op_tok = optab[Val0(op)].tok.t_type; + + /* + * Produce code for the value to be transmitted. + */ + if (op_tok == AUGAT) { + /* + * Augmented activation. This is seldom used so don't try too + * hard to optimize it. Allocate contiguous temporaries for + * the operands to the assignment. + */ + lifetm_ary = alc_lftm(2, &n->n_field[1]); + tmp_indx = alc_tmp(2, lifetm_ary); + asgn1 = tmp_loc(tmp_indx++); + asgn2 = tmp_loc(tmp_indx); + free((char *)lifetm_ary); + + /* + * Generate code to produce the left-hand-side of the assignment. + * This is also the transmitted value. Activation may need a + * dereferenced value, so this must be in a different location. + */ + gencode(transmit, asgn1); + trans_loc = chk_alc(NULL, n->intrnl_lftm); + setloc(op); + deref_ret(asgn1, trans_loc, varsubtyp(transmit->type, NULL)); + } + else + trans_loc = genretval(op, transmit, NULL); /* ordinary activation */ + + /* + * Determine if the value to be activated needs dereferencing, and + * see if it can only come from a single named variable. + */ + c_deref = HasVar(varsubtyp(coexpr->type, &c_single)); + if (c_single == NULL) { + /* + * The value is something other than a single named variable. + */ + coexpr_loc = gencode(coexpr, NULL); + if (c_deref) + deref_cd(coexpr_loc, coexpr_loc); + } + else { + /* + * The value is in a named variable. Use it directly from the + * variable rather than saving the result of the expression. + */ + gencode(coexpr, &ignore); + coexpr_loc = var_ref(c_single); + } + + /* + * Make sure the value to be activated is a co-expression. Perform + * run-time checking if necessary. + */ + cur_symtyps = n->symtyps; + if (eval_is(coexp_typ, 1) & MaybeFalse) { + lbl = alc_lbl("is co-expression", 0); + cd_add(lbl); + cur_fnc->cursor = lbl->prev; /* code goes before label */ + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(3); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "("; + cd1->ElemTyp(1) = A_ValLoc; + cd1->ValLoc(1) = coexpr_loc; + cd1->ElemTyp(2) = A_Str; + cd1->Str(2) = ").dword == D_Coexpr"; + cd->Cond = cd1; + cd->ThenStmt = mk_goto(lbl); + cd_add(cd); + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "err_msg(118, &("; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = coexpr_loc; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = "));"; + cd_add(cd); + if (err_conv) + cd_add(sig_cd(on_failure, cur_fnc)); + cur_fnc->cursor = lbl; + } + + /* + * Make sure a result location has been allocated. For ordinary + * activation, this is where activate() puts its result. For + * augmented activation, this is where assignment puts its result. + */ + rslt = chk_alc(rslt, n->lifetime); + if (op_tok == AUGAT) + act_rslt = asgn2; + else + act_rslt = rslt; + + /* + * Generate code to call activate(). + */ + setloc(n); + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(7); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "activate(&"; + cd1->ElemTyp(1) = A_ValLoc; + cd1->ValLoc(1) = trans_loc; + cd1->ElemTyp(2) = A_Str; + cd1->Str(2) = ", (struct b_coexpr *)BlkLoc("; + cd1->ElemTyp(3) = A_ValLoc; + cd1->ValLoc(3) = coexpr_loc; + cd1->ElemTyp(4) = A_Str; + cd1->Str(4) = "), &"; + cd1->ElemTyp(5) = A_ValLoc; + cd1->ValLoc(5) = act_rslt; + cd1->ElemTyp(6) = A_Str; + cd1->Str(6) = ") == A_Resume"; + cd->Cond = cd1; + cd->ThenStmt = sig_cd(on_failure, cur_fnc); + cd_add(cd); + + /* + * For augmented activation, generate code to call assignment. + */ + if (op_tok == AUGAT) { + impl = optab[asgn_loc].binary; + if (impl == NULL) { + nfatal(op, "assignment not implemented", NULL); + rslt = &ignore; /* make sure code generation can continue */ + } + else { + implproto(impl); + mk_callop(oper_name(impl), impl->ret_flag, asgn1, 2, rslt, 0); + } + } + + return rslt; + } + +/* + * save_env - generate code to save scanning environment. + */ +static void save_env(sub_sav, pos_sav) +struct val_loc *sub_sav; +struct val_loc *pos_sav; + { + struct code *cd; + + cd = alc_ary(2); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = sub_sav; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = k_subject;"; + cd_add(cd); + cd = alc_ary(2); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = pos_sav; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = k_pos;"; + cd_add(cd); + } + +/* + * restr_env - generate code to restore scanning environment. + */ +static void restr_env(sub_sav, pos_sav) +struct val_loc *sub_sav; +struct val_loc *pos_sav; + { + struct code *cd; + + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "k_subject = "; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = sub_sav; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ";"; + cd_add(cd); + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "k_pos = "; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = pos_sav; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ";"; + cd_add(cd); + } + +/* + * mk_callop - produce the code to directly call an operation. + */ +static void mk_callop(oper_nm, ret_flag, arg1rslt, nargs, rslt, optim) +char *oper_nm; +int ret_flag; +struct val_loc *arg1rslt; +int nargs; +struct val_loc *rslt; +int optim; + { + struct code *arg_lst; + struct code *on_ret; + struct c_fnc *fnc; + int n; + int need_cont; + + /* + * If this operation can return an "continue" signal, we will need + * a break statement in the signal switch to handle it. + */ + if (ret_flag & DoesRet) { + on_ret = NewCode(1); /* #fields == #fields C_Goto */ + on_ret->cd_id = C_Break; + on_ret->next = NULL; + on_ret->prev = NULL; + } + else + on_ret = NULL; + + /* + * Construct argument list for the C function implementing the + * operation. First compute the size of the code array for the + * argument list; this varies if we are using an optimized calling + * interface. + */ + if (optim) { + n = 0; + if (arg1rslt != NULL) + n += 2; + if (ret_flag & (DoesRet | DoesSusp)) { + if (n > 0) + ++n; + n += 2; + } + } + else + n = 7; + if (n == 0) + arg_lst = NULL; + else { + arg_lst = alc_ary(n); + n = 0; + if (!optim) { + arg_lst->ElemTyp(n) = A_Intgr; /* number of arguments */ + arg_lst->Intgr(n) = nargs; + ++n; + arg_lst->ElemTyp(n) = A_Str; /* , */ + arg_lst->Str(n) = ", "; + ++n; + } + if (arg1rslt == NULL) { /* location of first argument */ + if (!optim) { + arg_lst->ElemTyp(n) = A_Str; + arg_lst->Str(n) = "NULL"; + ++n; + arg_lst->ElemTyp(n) = A_Str; + arg_lst->Str(n) = ""; /* nothing, but must fill slot */ + ++n; + } + } + else { + arg_lst->ElemTyp(n) = A_Str; + arg_lst->Str(n) = "&"; + ++n; + arg_lst->ElemTyp(n) = A_ValLoc; + arg_lst->ValLoc(n) = arg1rslt; + ++n; + } + if (!optim || ret_flag & (DoesRet | DoesSusp)) { + if (n > 0) { + arg_lst->ElemTyp(n) = A_Str; /* , */ + arg_lst->Str(n) = ", "; + ++n; + } + arg_lst->ElemTyp(n) = A_Str; /* location of result */ + arg_lst->Str(n) = "&"; + ++n; + arg_lst->ElemTyp(n) = A_ValLoc; + arg_lst->ValLoc(n) = rslt; + } + } + + /* + * Generate code to call the operation and handle returned signals. + */ + if (ret_flag & DoesSusp) { + /* + * The operation suspends, so call it with a continuation, then + * proceed to generate code in the continuation. + */ + fnc = alc_fnc(); + callo_add(oper_nm, ret_flag, fnc, 1, arg_lst, on_ret); + if (ret_flag & DoesRet) + callc_add(fnc); + cur_fnc = fnc; + on_failure = &resume; + } + else { + /* + * No continuation is needed, but if standard calling conventions + * are used, a NULL continuation argument is required. + */ + if (optim) + need_cont = 0; + else + need_cont = 1; + callo_add(oper_nm, ret_flag, NULL, need_cont, arg_lst, on_ret); + } +} + +/* + * genretval - generate code for the expression in a return/suspend or + * for the expression for the value to be transmitted in a co-expression + * context switch. + */ +static struct val_loc *genretval(n, expr, dest) +struct node *n; +struct node *expr; +struct val_loc *dest; + { + int subtypes; + struct lentry *single; + struct val_loc *val; + + subtypes = varsubtyp(expr->type, &single); + + /* + * If we have a single local or argument, we don't need to construct + * a variable reference; we need the value and we know where it is. + */ + if (single != NULL && (subtypes & (HasLcl | HasPrm))) { + gencode(expr, &ignore); + val = var_ref(single); + if (dest == NULL) + dest = val; + else + cd_add(mk_cpyval(dest, val)); + } + else { + dest = gencode(expr, dest); + setloc(n); + deref_ret(dest, dest, subtypes); + } + + return dest; + } + +/* + * deref_ret - produced dereferencing code for values returned from + * procedures or transmitted to co-expressions. + */ +static void deref_ret(src, dest, subtypes) +struct val_loc *src; +struct val_loc *dest; +int subtypes; + { + struct code *cd; + struct code *lbl; + + if (src == NULL) + return; /* no value to dereference */ + + /* + * If there may be values that do not need dereferencing, insure that the + * values are in the destination and make it the source of dereferencing. + */ + if ((subtypes & (HasVal | HasGlb)) && (src != dest)) { + cd_add(mk_cpyval(dest, src)); + src = dest; + } + + if (subtypes & (HasLcl | HasPrm)) { + /* + * Some values may need to be dereferenced. + */ + lbl = NULL; + if (subtypes & HasVal) { + /* + * We may have a non-variable and must check at run time. + */ + lbl = check_var(dest, NULL); + } + + if (subtypes & HasGlb) { + /* + * Make sure we don't dereference any globals, use retderef(). + */ + if (subtypes & HasLcl) { + /* + * We must dereference any locals. + */ + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "retderef(&"; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = dest; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = + ", (word *)pfp->tend.d, (word *)(pfp->tend.d + pfp->tend.num));"; + cd_add(cd); + /* + * We may now have a value. We must check at run-time and skip + * any attempt to dereference an argument. + */ + lbl = check_var(dest, lbl); + } + + if (subtypes & HasPrm) { + /* + * We must dereference any arguments. + */ + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "retderef(&"; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = dest; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ", (word *)glbl_argp, (word *)(glbl_argp + "; + cd->ElemTyp(3) = A_Intgr; + cd->Intgr(3) = Abs(cur_proc->nargs); + cd->ElemTyp(4) = A_Str; + cd->Str(4) = "));"; + cd_add(cd); + } + } + else /* No globals */ + deref_cd(src, dest); + + if (lbl != NULL) + cur_fnc->cursor = lbl; /* continue after label */ + } + } + +/* + * check_var - generate code to make sure a descriptor contains a variable + * reference. If no label is given to jump to for a non-variable, allocate + * one and generate code before it. + */ +static struct code *check_var(d, lbl) +struct val_loc *d; +struct code *lbl; + { + struct code *cd, *cd1; + + if (lbl == NULL) { + lbl = alc_lbl("not variable", 0); + cd_add(lbl); + cur_fnc->cursor = lbl->prev; /* code goes before label */ + } + + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(3); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "!Var("; + cd1->ElemTyp(1) = A_ValLoc; + cd1->ValLoc(1) = d; + cd1->ElemTyp(2) = A_Str; + cd1->Str(2) = ")"; + cd->Cond = cd1; + cd->ThenStmt = mk_goto(lbl); + cd_add(cd); + + return lbl; + } + +/* + * field_ref - generate code for a field reference. + */ +static struct val_loc *field_ref(n, rslt) +struct node *n; +struct val_loc *rslt; + { + struct node *rec; + struct node *fld; + struct fentry *fp; + struct par_rec *rp; + struct val_loc *rec_loc; + struct code *cd; + struct code *cd1; + struct code *lbl; + struct lentry *single; + int deref; + int num_offsets; + int offset; + int bad_recs; + + rec = Tree0(n); + fld = Tree1(n); + + /* + * Generate code to compute the record value and dereference it. + */ + deref = HasVar(varsubtyp(rec->type, &single)); + if (single != NULL) { + /* + * The record is in a named variable. Use value directly from + * the variable rather than saving the result of the expression. + */ + gencode(rec, &ignore); + rec_loc = var_ref(single); + } + else { + rec_loc = gencode(rec, NULL); + if (deref) + deref_cd(rec_loc, rec_loc); + } + + setloc(fld); + + /* + * Make sure the operand is a record. + */ + cur_symtyps = n->symtyps; + if (eval_is(rec_typ, 0) & MaybeFalse) { + lbl = alc_lbl("is record", 0); + cd_add(lbl); + cur_fnc->cursor = lbl->prev; /* code goes before label */ + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(3); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "("; + cd1->ElemTyp(1) = A_ValLoc; + cd1->ValLoc(1) = rec_loc; + cd1->ElemTyp(2) = A_Str; + cd1->Str(2) = ").dword == D_Record"; + cd->Cond = cd1; + cd->ThenStmt = mk_goto(lbl); + cd_add(cd); + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "err_msg(107, &"; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = rec_loc; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ");"; + cd_add(cd); + if (err_conv) + cd_add(sig_cd(on_failure, cur_fnc)); + cur_fnc->cursor = lbl; + } + + rslt = chk_alc(rslt, n->lifetime); + + /* + * Find the list of records containing this field. + */ + if ((fp = flookup(Str0(fld))) == NULL) { + nfatal(n, "invalid field", Str0(fld)); + return rslt; + } + + /* + * Generate code for declarations and to get the record block pointer. + */ + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "{"; + cd_add(cd); + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "struct b_record *r_rp = (struct b_record *) BlkLoc("; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = rec_loc; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ");"; + cd_add(cd); + if (err_conv) { + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "int r_must_fail = 0;"; + cd_add(cd); + } + + /* + * Determine which records are in the record type. + */ + mark_recs(fp, cur_symtyps->types[0], &num_offsets, &offset, &bad_recs); + + /* + * Generate code to insure that the field belongs to the record + * and to index into the record block. + */ + if (num_offsets == 1 && !bad_recs) { + /* + * We already know the offset of the field. + */ + cd = alc_ary(4); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = rslt; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = ".dword = D_Var + ((word *)&r_rp->fields["; + cd->ElemTyp(2) = A_Intgr; + cd->Intgr(2) = offset; + cd->ElemTyp(3) = A_Str; + cd->Str(3) = "] - (word *)r_rp);"; + cd_add(cd); + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "VarLoc("; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = rslt; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ") = (dptr)r_rp;"; + cd_add(cd); + for (rp = fp->rlist; rp != NULL; rp = rp->next) + rp->mark = 0; + } + else { + /* + * The field appears in several records. generate code to determine + * which one it is. + */ + + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "dptr r_dp;"; + cd_add(cd); + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "switch (r_rp->recdesc->proc.recnum) {"; + cd_add(cd); + + rp = fp->rlist; + while (rp != NULL) { + offset = rp->offset; + while (rp != NULL && rp->offset == offset) { + if (rp->mark) { + rp->mark = 0; + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = " case "; + cd->ElemTyp(1) = A_Intgr; + cd->Intgr(1) = rp->rec->rec_num; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ":"; + cd_add(cd); + } + rp = rp->next; + } + + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = " r_dp = &r_rp->fields["; + cd->ElemTyp(1) = A_Intgr; + cd->Intgr(1) = offset; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = "];"; + cd_add(cd); + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = " break;"; + cd_add(cd); + } + + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = " default:"; + cd_add(cd); + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = " err_msg(207, &"; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = rec_loc; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ");"; + cd_add(cd); + if (err_conv) { + /* + * The peephole analyzer doesn't know how to handle a goto or return + * in a switch statement, so just set a flag here. + */ + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = " r_must_fail = 1;"; + cd_add(cd); + } + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = " }"; + cd_add(cd); + if (err_conv) { + /* + * Now that we are out of the switch statement, see if the flag + * was set to indicate error conversion. + */ + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(1); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "r_must_fail"; + cd->Cond = cd1; + cd->ThenStmt = sig_cd(on_failure, cur_fnc); + cd_add(cd); + } + cd = alc_ary(2); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = rslt; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = ".dword = D_Var + ((word *)r_dp - (word *)r_rp);"; + cd_add(cd); + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "VarLoc("; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = rslt; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ") = (dptr)r_rp;"; + cd_add(cd); + } + + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "}"; + cd_add(cd); + return rslt; + } + +/* + * bound - bound the code for the given sub-tree. If catch_fail is true, + * direct failure to the bounding label. + */ +static struct val_loc *bound(n, rslt, catch_fail) +struct node *n; +struct val_loc *rslt; +int catch_fail; + { + struct code *lbl1; + struct code *fail_sav; + struct c_fnc *fnc_sav; + + fnc_sav = cur_fnc; + fail_sav = on_failure; + + lbl1 = alc_lbl("bound", Bounding); + cd_add(lbl1); + cur_fnc->cursor = lbl1->prev; /* code goes before label */ + if (catch_fail) + on_failure = lbl1; + + rslt = gencode(n, rslt); + + cd_add(sig_cd(lbl1, cur_fnc)); /* transfer control to bounding label */ + cur_fnc = fnc_sav; + cur_fnc->cursor = lbl1; + + on_failure = fail_sav; + return rslt; + } + +/* + * cd_add - add a code struct at the cursor in the current function. + */ +void cd_add(cd) +struct code *cd; + { + register struct code *cursor; + + cursor = cur_fnc->cursor; + + cd->next = cursor->next; + cd->prev = cursor; + if (cursor->next != NULL) + cursor->next->prev = cd; + cursor->next = cd; + cur_fnc->cursor = cd; + } + +/* + * sig_cd - convert a signal/label into a goto or return signal in + * the context of the given function. + */ +struct code *sig_cd(sig, fnc) +struct code *sig; +struct c_fnc *fnc; + { + struct code *cd; + + if (sig->cd_id == C_Label && sig->Container == fnc) + return mk_goto(sig); + else { + cd = NewCode(1); /* # fields <= # fields of C_Goto */ + cd->cd_id = C_RetSig; + cd->next = NULL; + cd->prev = NULL; + cd->SigRef = add_sig(sig, fnc); + return cd; + } + } + +/* + * add_sig - add signal to list of signals returned by function. + */ +struct sig_lst *add_sig(sig, fnc) +struct code *sig; +struct c_fnc *fnc; + { + struct sig_lst *sl; + + for (sl = fnc->sig_lst; sl != NULL && sl->sig != sig; sl = sl->next) + ; + if (sl == NULL) { + sl = NewStruct(sig_lst); + sl->sig = sig; + sl->ref_cnt = 1; + sl->next = fnc->sig_lst; + fnc->sig_lst = sl; + } + else + ++sl->ref_cnt; + return sl; + } + +/* + * callc_add - add code to call a continuation. Note the action to be + * taken if the continuation returns resumption. The actual list + * signals returned and actions to take will be figured out after + * the continuation has been optimized. + */ +void callc_add(cont) +struct c_fnc *cont; + { + struct code *cd; + + cd = new_call(); + cd->OperName = NULL; + cd->Cont = cont; + cd->ArgLst = NULL; + cd->ContFail = on_failure; + cd->SigActs = NULL; + ++cont->ref_cnt; + } + +/* + * callo_add - add code to call an operation. + */ +void callo_add(oper_nm, ret_flag, cont, need_cont, arglist, on_ret) +char *oper_nm; +int ret_flag; +struct c_fnc *cont; +int need_cont; +struct code *arglist; +struct code *on_ret; + { + struct code *cd; + struct code *cd1; + + cd = new_call(); + cd->OperName = oper_nm; + cd->Cont = cont; + if (need_cont) + cd->Flags = NeedCont; + cd->ArgLst = arglist; + cd->ContFail = NULL; /* operation handles failure from the continuation */ + /* + * Decide how to handle the signals produced by the operation. (Those + * produced by the continuation will be examined after the continuation + * is optimized.) + */ + cd->SigActs = NULL; + if (MightFail(ret_flag)) + cd->SigActs = new_sgact(&resume, sig_cd(on_failure,cur_fnc), cd->SigActs); + if (ret_flag & DoesRet) + cd->SigActs = new_sgact(&contin, on_ret, cd->SigActs); + if (ret_flag & DoesFThru) { + cd1 = NewCode(1); /* #fields == #fields C_Goto */ + cd1->cd_id = C_Break; + cd1->next = NULL; + cd1->prev = NULL; + cd->SigActs = new_sgact(&fallthru, cd1, cd->SigActs); + } + if (cont != NULL) + ++cont->ref_cnt; /* increment reference count */ +} + +/* + * Create a call, add it to the code for the current function, and + * add it to the list of calls from the current function. + */ +static struct code *new_call() + { + struct code *cd; + + cd = NewCode(7); + cd->cd_id = C_CallSig; + cd_add(cd); + cd->Flags = 0; + cd->NextCall = cur_fnc->call_lst; + cur_fnc->call_lst = cd; + return cd; + } + +/* + * sig_act - create a new binding of an action to a signal. + */ +struct sig_act *new_sgact(sig, cd, next) +struct code *sig; +struct code *cd; +struct sig_act *next; + { + struct sig_act *sa; + + sa = NewStruct(sig_act); + sa->sig = sig; + sa->cd = cd; + sa->shar_act = NULL; + sa->next = next; + return sa; + } + + +#ifdef OptimizeLit +static int instr(const char *str, int chr) { + int i, found, go; + + found = 0; go = 1; + for(i=0; ((str[i] != '\0') && go) ;i++) { + if (str[i] == chr) { + go = 0; + found = 1; + if ((str[i+1] != '\0') && (chr == '=')) + if (str[i+1] == '=') + found = 0; + if ((chr == '=') && (i > 0)) { + if (str[i-1] == '>') + found = 0; + else if (str[i-1] == '<') + found = 0; + else if (str[i-1] == '!') + found = 0; + } + } + } + return found; +} + +static void tbl_add(struct lit_tbl *add) { + struct lit_tbl *ins; + static struct lit_tbl *ptr = NULL; + int go = 1; + + if (tbl == NULL) { + tbl = add; + ptr = add; + } + else { + ins = ptr; + while ((ins != NULL) && go) { + if (add->index != ins->index) + ins = ins->prev; + else + go = 0; + } + if (ins != NULL) { + if (ins->end == NULL) + ins->end = add->initial; + } + ptr->next = add; + add->prev = ptr; + ptr = add; + } +} + + +static void invalidate(struct val_loc *val, struct code *end, int code) { + struct lit_tbl *ptr, *back; + int index, go = 1; + + if (val == NULL) + return; + if (val->loc_type == V_NamedVar) { + index = val->u.nvar->val.index; + return; + } + else if (val->loc_type == V_Temp) + index = val->u.tmp + cur_proc->tnd_loc; + else + return; + if (tbl == NULL) + return; + back = tbl; + while (back->next != NULL) + back = back->next; + go = 1; + for(ptr=back; ((ptr != NULL) && go) ; ptr=ptr->prev) { + if ((ptr->index == index) && (ptr->modified != NO_TOUCH)) { + ptr->modified = code; + if ((code != LIMITED_TO_INT) && (ptr->safe)) { + ptr->end = end; + ptr->safe = 0; + } + go = 0; + } + else if ((ptr->index == index) && (ptr->modified == NO_TOUCH)) { + if ((code != LIMITED_TO_INT) && (ptr->safe)) { + ptr->end = end; + ptr->safe = 0; + } + go = 0; + } + else if (ptr->index == index) + go = 0; + } +} + + +static int eval_code(struct code *cd, struct lit_tbl *cur) { + struct code *tmp; + struct lit_tbl *tmp_tbl; + int i, j; + char *str; + + for (i=0; cd->ElemTyp(i) != A_End ;i++) { + switch(cd->ElemTyp(i)) { + case A_ValLoc: + if (cd->ValLoc(i)->mod_access != M_CInt) + break; + if ((cd->ValLoc(i)->u.tmp + cur_proc->tnd_loc) == cur->index) { + switch (cd->ValLoc(i)->loc_type) { + case V_Temp: + if (cur->csym->flag == F_StrLit) { +#if 0 + cd->ElemTyp(i) = A_Str; + str = (char *)alloc(strlen(cur->csym->image)+8); + sprintf(str, "\"%s\"/*Z*/", cur->csym->image); + cd->Str(i) = str; +#endif + } + else if (cur->csym->flag == F_IntLit) { + cd->ElemTyp(i) = A_Str; + cd->Str(i) = cur->csym->image; + } + break; + default: + break; + } + } + break; + case A_Ary: + for(tmp=cd->Array(i); tmp != NULL ;tmp=tmp->next) + eval_code(tmp, cur); + break; + default: + break; + } + } +} + +static void propagate_literals() { + struct lit_tbl *ptr; + struct code *cd, *arg; + int ret; + + for(ptr=tbl; ptr != NULL ;ptr=ptr->next) { + if (ptr->modified != NO_TOUCH) { + for(cd=ptr->initial; cd != ptr->end ;cd=cd->next) { + switch (cd->cd_id) { + case C_If: + for(arg=cd->Cond; arg != NULL ;arg=arg->next) + ret = eval_code(arg, ptr); + /* + * Again, don't take the 'then' portion. + * It might lead to infinite loops. + * for(arg=cd->ThenStmt; arg != NULL ;arg=arg->next) + * ret = eval_code(arg, ptr); + */ + break; + case C_CdAry: + ret = eval_code(cd, ptr); + break; + case C_CallSig: + for(arg=cd->ArgLst; arg != NULL ;arg=arg->next) + ret = eval_code(arg, ptr); + break; + default: + break; + } + } + } + } +} + +/* + * analyze_literals - analyzes the generated code to replace + * complex record dereferences with C + * literals. + */ +static void analyze_literals(struct code *start, struct code *top, int lvl) { + struct code *ptr, *tmp, *not_null; + struct lit_tbl *new_tbl; + struct lbl_tbl *new_lbl; + struct val_loc *prev = NULL; + int i, inc=0, addr=0, assgn=0, equal = 0; + + for (ptr = start; ptr != NULL ; ptr = ptr->next) { + if (!lvl) + not_null = ptr; + else + not_null = top; + switch (ptr->cd_id) { + case C_NamedVar: + break; + case C_CallSig: + analyze_literals(ptr->ArgLst, not_null, lvl+1); + break; + case C_Goto: + break; + case C_Label: + break; + case C_Lit: + new_tbl = alc_tbl(); + new_tbl->initial = ptr; + new_tbl->vloc = ptr->Rslt; + new_tbl->csym = ptr->Literal; + switch (ptr->Rslt->loc_type) { + case V_NamedVar: + new_tbl->index = ptr->Rslt->u.nvar->val.index; + tbl_add(new_tbl); + break; + case V_Temp: + new_tbl->index = ptr->Rslt->u.tmp + cur_proc->tnd_loc; + tbl_add(new_tbl); + break; + default: + new_tbl->index = -1; + free(new_tbl); + break; + } + break; + case C_If: + analyze_literals(ptr->Cond, not_null, lvl+1); + /* + * Don't analyze the 'then' portion such as in: + * analyze_literals(ptr->ThenStmt, not_null, lvl+1); + * Apparently, all the intermediate code does is maintain + * a pointer to where the flow of execution jumps to in + * case the 'then' is taken. These are all goto statments + * and can result in infinite loops of analyzation. + */ + break; + case C_CdAry: + for(i=0; ptr->ElemTyp(i) != A_End ;i++) { + switch(ptr->ElemTyp(i)) { + case A_Str: + if (ptr->Str(i) != NULL) { + if ( (strstr(ptr->Str(i), "-=")) || + (strstr(ptr->Str(i), "+=")) || + (strstr(ptr->Str(i), "*=")) || + (strstr(ptr->Str(i), "/=")) ) + invalidate(prev, not_null, NO_TOUCH); + else if (instr(ptr->Str(i), '=')) { + invalidate(prev, not_null, LIMITED); + assgn = 1; + } + else if ( (strstr(ptr->Str(i), "++")) || + (strstr(ptr->Str(i), "--")) ) + inc = 1; + else if (instr(ptr->Str(i), '&')) + addr = 1; + else if (strstr(ptr->Str(i), "==")) + equal = 1; + } + break; + case A_ValLoc: + if (inc) { + invalidate(ptr->ValLoc(i), not_null, NO_TOUCH); + inc = 0; + } + if (addr) { + invalidate(ptr->ValLoc(i), not_null, LIMITED); + addr = 0; + } + if ((assgn) && (ptr->ValLoc(i)->mod_access == M_None)) { + invalidate(ptr->ValLoc(i), not_null, LIMITED); + assgn = 0; + } + else if (assgn) + assgn = 0; + if (equal) { + invalidate(ptr->ValLoc(i), not_null, LIMITED_TO_INT); + equal = 0; + } + prev = ptr->ValLoc(i); + break; + case A_Intgr: + break; + case A_SBuf: + break; + case A_Ary: + for(tmp=ptr->Array(i); tmp != NULL ;tmp=tmp->next) + analyze_literals(tmp, not_null, lvl+1); + break; + default: + break; + } + } + break; + default: + break; + } + } +} +#endif /* OptimizeLit */ + +/* + * analyze_poll - analyzes the internal C code representation from + * the position of the last Poll() function call to + * the current position in the code. + * Returns a 0 if the last Poll() function should not + * be removed. + */ +#ifdef OptimizePoll +static int analyze_poll(void) { + struct code *cursor, *ptr; + int cont = 1; + + ptr = lastpoll; + if (ptr == NULL) + return 0; + cursor = cur_fnc->cursor; + while ((cursor != ptr) && (ptr != NULL) && (cont)) { + switch (ptr->cd_id) { + case C_Null : + case C_NamedVar : + case C_Label : + case C_Lit : + case C_Resume : + case C_Continue : + case C_FallThru : + case C_PFail : + case C_Goto : + case C_Create : + case C_If : + case C_SrcLoc : + case C_CdAry : + break; + case C_CallSig : + case C_RetSig : + case C_LBrack : + case C_RBrack : + case C_PRet : + case C_PSusp : + case C_Break : + cont = 0; + break; + } + ptr = ptr->next; + } + return cont; +} + +/* + * remove_poll - removes the ccode structure that represents the last + * call to the "Poll()" function by simply changing the code ID to + * C_Null code. + */ +static void remove_poll(void) { + + if (lastpoll == NULL) + return; + lastpoll->cd_id = C_Null; +} +#endif /* OptimizePoll */ + +/* + * setloc produces code to set the file name and line number to the + * source location of node n. Code is only produced if the corresponding + * value has changed since the last time setloc was called. + */ +static void setloc(n) +nodeptr n; + { + struct code *cd; + static int count=0; + + if (n == NULL || File(n) == NULL || Line(n) == 0) + return; + + if (File(n) != lastfiln || Line(n) != lastline) { +#ifdef OptimizePoll + if (analyze_poll()) + remove_poll(); + cd = alc_ary(1); + lastpoll = cd; +#else /* OptimizePoll */ + cd = alc_ary(1); +#endif /* OptimizePoll */ + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "Poll();"; + cd_add(cd); + + if (line_info) { + cd = NewCode(2); + cd->cd_id = C_SrcLoc; + + if (File(n) == lastfiln) + cd->FileName = NULL; + else { + lastfiln = File(n); + cd->FileName = lastfiln; + } + + if (Line(n) == lastline) + cd->LineNum = 0; + else { + lastline = Line(n); + cd->LineNum = lastline; + } + + cd_add(cd); + } + } + } + +/* + * alc_ary - create an array for a sequence of code fragments. + */ +struct code *alc_ary(n) +int n; + { + struct code *cd; + static cnt=1; + + cd = NewCode(2 * n + 1); + cd->cd_id = C_CdAry; + cd->next = NULL; + cd->prev = NULL; + cd->ElemTyp(n) = A_End; + return cd; + } + + +/* + * alc_lbl - create a label. + */ +struct code *alc_lbl(desc, flag) +char *desc; +int flag; + { + register struct code *cd; + + cd = NewCode(5); + cd->cd_id = C_Label; + cd->next = NULL; + cd->prev = NULL; + cd->Container = cur_fnc; /* function containing label */ + cd->SeqNum = 0; /* sequence number is allocated later */ + cd->Desc = desc; /* identifying comment */ + cd->RefCnt = 0; /* reference count */ + cd->LabFlg = flag; + return cd; + } + +/* + * alc_fnc - allocate a function structure; + */ +static struct c_fnc *alc_fnc() + { + register struct c_fnc *cf; + int i; + + cf = NewStruct(c_fnc); + cf->prefix[0] = '\0'; /* prefix is allocated later */ + cf->prefix[PrfxSz] = '\0'; /* terminate prefix for printing */ + cf->flag = 0; + for (i = 0; i < PrfxSz; ++i) + cf->frm_prfx[i] = frm_prfx[i]; /* note procedure frame prefix */ + cf->frm_prfx[PrfxSz] = '\0'; /* terminate prefix for printing */ + cf->cd.cd_id = C_Null; /* base of code sequence in function */ + cf->cd.next = NULL; + cf->cursor = &cf->cd; /* current place to insert code */ + cf->call_lst = NULL; /* functions called by this function */ + cf->creatlst = NULL; /* creates within this function */ + cf->sig_lst = NULL; /* signals returned by this function */ + cf->ref_cnt = 0; + cf->next = NULL; + *flst_end = cf; /* link entry onto global list */ + flst_end = &(cf->next); + return cf; + } + +/* + * tmp_loc - allocate a value location structure for nth temporary descriptor + * variable in procedure frame. + */ +static struct val_loc *tmp_loc(n) +int n; + { + register struct val_loc *r; + + r = NewStruct(val_loc); + r->loc_type = V_Temp; + r->mod_access = M_None; + r->u.tmp = n; + return r; + } + +/* + * itmp_loc - allocate a value location structure for nth temporary integer + * variable in procedure frame. + */ +struct val_loc *itmp_loc(n) +int n; + { + register struct val_loc *r; + + r = NewStruct(val_loc); + r->loc_type = V_ITemp; + r->mod_access = M_None; + r->u.tmp = n; + return r; + } + +/* + * dtmp_loc - allocate a value location structure for nth temporary double + * variable in procedure frame. + */ +struct val_loc *dtmp_loc(n) +int n; + { + register struct val_loc *r; + + r = NewStruct(val_loc); + r->loc_type = V_DTemp; + r->mod_access = M_None; + r->u.tmp = n; + return r; + } + +/* + * vararg_sz - allocate a value location structure that refers to the size + * of the variable part of an argument list. + */ +static struct val_loc *vararg_sz(n) +int n; + { + register struct val_loc *r; + + r = NewStruct(val_loc); + r->loc_type = V_Const; + r->mod_access = M_None; + r->u.int_const = n; + return r; + } + +/* + * cvar_loc - allocate a value location structure for a C variable. + */ +struct val_loc *cvar_loc(name) +char *name; + { + register struct val_loc *r; + + r = NewStruct(val_loc); + r->loc_type = V_CVar; + r->mod_access = M_None; + r->u.name = name; + return r; + } + +/* + * var_ref - allocate a value location structure for an Icon named variable. + */ +static struct val_loc *var_ref(sym) +struct lentry *sym; + { + struct val_loc *loc; + + loc = NewStruct(val_loc); + loc->loc_type = V_NamedVar; + loc->mod_access = M_None; + loc->u.nvar = sym; + return loc; + } + +/* + * deref_cd - generate code to dereference a descriptor. + */ +static void deref_cd(src, dest) +struct val_loc *src; +struct val_loc *dest; + { + struct code *cd; + + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "deref(&"; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = src; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ", &"; + cd->ElemTyp(3) = A_ValLoc; + cd->ValLoc(3) = dest; + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ");"; + cd_add(cd); + } + +/* + * inv_op - directly invoke a run-time operation, in-lining it if possible. + */ +static struct val_loc *inv_op(n, rslt) +nodeptr n; +struct val_loc *rslt; + { + struct implement *impl; + struct code *scont_strt; + struct code *scont_fail; + struct c_fnc *fnc; + struct val_loc *frst_arg; + struct val_loc *arg_rslt; + struct val_loc *r; + struct val_loc **varg_rslt; + struct op_symentry *symtab; + struct lentry **single; + struct tmplftm *lifetm_ary; + nodeptr rslt_lftm; + char *sbuf; + int *maybe_var; + int may_mod; + int nsyms; + int nargs; + int nparms; + int cont_loc; + int flag; + int refs; + int var_args; + int n_varargs; + int arg_loc; + int dcl_var; + int i; + int j; + int v; + + nargs = Val0(n); + impl = Impl1(n); + if (impl == NULL) { + /* + * We have already printed an error, just make sure we can + * continue. + */ + return &ignore; + } + + /* + * If this operation uses its result location as a work area, it must + * be given a tended result location and the value must be retained + * as long as the operation can be resumed. + */ + rslt_lftm = n->lifetime; + if (impl->use_rslt) { + rslt_lftm = max_lftm(rslt_lftm, n->intrnl_lftm); + if (rslt == &ignore) + rslt = NULL; /* force allocation of temporary */ + } + + /* + * Determine if this operation takes a variable number of arguments + * and determine the size of the variable part of the arg list. + */ + nparms = impl->nargs; + if (nparms > 0 && impl->arg_flgs[nparms - 1] & VarPrm) { + var_args = 1; + n_varargs = nargs - nparms + 1; + if (n_varargs < 0) + n_varargs = 0; + } + else { + var_args = 0; + n_varargs = 0; + } + + /* + * Construct a symbol table (implemented as an array) for the operation. + * The symbol table includes parameters, and both the tended and + * ordinary variables from the RTL declare statement. + */ + nsyms = (n->symtyps == NULL ? 0 : n->symtyps->nsyms); + if (var_args) + ++nsyms; + nsyms += impl->ntnds + impl->nvars; + if (nsyms > 0) + symtab = (struct op_symentry *)alloc((unsigned int)(nsyms * + sizeof(struct op_symentry))); + else + symtab = NULL; + for (i = 0; i < nsyms; ++i) { + symtab[i].n_refs = 0; /* number of non-modifying references */ + symtab[i].n_mods = 0; /* number of modifying references */ + symtab[i].n_rets = 0; /* number of times returned directly */ + symtab[i].var_safe = 0; /* Icon variable arg can be passed directly */ + symtab[i].adjust = 0; /* adjustments needed to "dereference" */ + symtab[i].itmp_indx = -1; /* loc after "in-place" convert to C integer */ + symtab[i].dtmp_indx = -1; /* loc after "in-place" convert to C double */ + symtab[i].loc = NULL; /* location as a descriptor */ + } + + /* + * If in-lining has not been disabled or the operation is a keyword, + * check to see if it can reasonably be in-lined and gather information + * needed to in-line it. + */ + if ((allow_inline || impl->oper_typ == 'K') && + do_inlin(impl, n, &cont_loc, symtab, n_varargs)) { + /* + * In-line the operation. + */ + + if (impl->ret_flag & DoesRet || impl->ret_flag & DoesSusp) + rslt = chk_alc(rslt, rslt_lftm); /* operation produces a result */ + + /* + * Allocate arrays to hold information from type inferencing about + * whether arguments are variables. This is used to optimize + * dereferencing. + */ + if (nargs > 0) { + maybe_var = (int *)alloc((unsigned int)(nargs * sizeof(int))); + single = (struct lentry **)alloc((unsigned int)(nargs * + sizeof(struct lentry *))); + } + + if (var_args) + --nparms; /* don't deal with varargs parameter yet. */ + + /* + * Match arguments with parameters and generate code for the + * arguments. The type of code generated depends on the kinds + * of dereferencing optimizations that are possible, though + * in general, dereferencing must wait until all arguments are + * computed. Because there may be both dereferenced and undereferenced + * parameters for an argument, the symbol table index does not always + * match the argument index. + */ + i = 0; /* symbol table index */ + for (j = 0; j < nparms && j < nargs; ++j) { + /* + * Use information from type inferencing to determine if the + * argument might me a variable and whether it is a single + * known named variable. + */ + maybe_var[j] = HasVar(varsubtyp(n->n_field[FrstArg + j].n_ptr->type, + &(single[j]))); + + /* + * Determine how many times the argument is referenced. If we + * optimize away return statements because we don't need the + * result, those references don't count. Take into account + * that there may be both dereferenced and undereferenced + * parameters for this argument. + */ + if (rslt == &ignore) + symtab[i].n_refs -= symtab[i].n_rets; + refs = symtab[i].n_refs + symtab[i].n_mods; + flag = impl->arg_flgs[j] & (RtParm | DrfPrm); + if (flag == (RtParm | DrfPrm)) + refs += symtab[i + 1].n_refs + symtab[i + 1].n_mods; + if (refs == 0) { + /* + * Indicate that we don't need the argument value (we must + * still perform the computation in case it has side effects). + */ + arg_rslt = &ignore; + symtab[i].adjust = AdjNone; + } + else { + /* + * Decide whether the result location for the argument can be + * used directly as the parameter. + */ + if (flag == (RtParm | DrfPrm) && symtab[i].n_refs + + symtab[i].n_mods == 0) { + /* + * We have both dereferenced and undereferenced parameters, + * but don't use the undereferenced one so ignore it. + */ + symtab[i].adjust = AdjNone; + ++i; + flag = DrfPrm; + } + if (flag == DrfPrm && single[j] != NULL) { + /* + * We need only a dereferenced value, but know what variable + * it is in. We don't need the computed argument value, we will + * get it directly from the variable. If it is safe to do + * so, we will pass a pointer to the variable as the argument + * to the operation. + */ + arg_rslt = &ignore; + symtab[i].loc = var_ref(single[j]); + if (symtab[i].var_safe) + symtab[i].adjust = AdjNone; + else + symtab[i].adjust = AdjCpy; + } + else { + /* + * Determine if the argument descriptor is modified by the + * operation; dereferencing a variable is a modification. + */ + may_mod = (symtab[i].n_mods != 0); + if (flag == DrfPrm) + may_mod |= maybe_var[j]; + if (n->n_field[FrstArg + j].n_ptr->reuse && may_mod) { + /* + * The parameter may be reused without recomputing + * the argument and the value may be modified. The + * argument result location and the parameter location + * must be separate so the parameter is reloaded upon + * each invocation. + */ + arg_rslt = chk_alc(NULL, + n->n_field[FrstArg + j].n_ptr->lifetime); + if (flag == DrfPrm && maybe_var[j]) + symtab[i].adjust = AdjNDrf; /* var: must dereference */ + else + symtab[i].adjust = AdjCpy; /* value only: just copy */ + } + else { + /* + * Argument result location will act as parameter location. + * Its lifetime must be as long as both that of the + * the argument and the parameter (operation internal + * lifetime). + */ + arg_rslt = chk_alc(NULL, max_lftm(n->intrnl_lftm, + n->n_field[FrstArg + j].n_ptr->lifetime)); + if (flag == DrfPrm && maybe_var[j]) + symtab[i].adjust = AdjDrf; /* var: must dereference */ + else + symtab[i].adjust = AdjNone; + } + symtab[i].loc = arg_rslt; + } + } + + /* + * Generate the code for the argument. + */ + gencode(n->n_field[FrstArg + j].n_ptr, arg_rslt); + + if (flag == (RtParm | DrfPrm)) { + /* + * We have computed the value for the undereferenced parameter, + * decide how to get the dereferenced value. + */ + ++i; + if (symtab[i].n_refs + symtab[i].n_mods == 0) + symtab[i].adjust = AdjNone; /* not needed, ignore */ + else { + if (single[j] != NULL) { + /* + * The value is in a specific Icon variable, get it from + * there. If is is safe to pass the variable directly + * to the operation, do so. + */ + symtab[i].loc = var_ref(single[j]); + if (symtab[i].var_safe) + symtab[i].adjust = AdjNone; + else + symtab[i].adjust = AdjCpy; + } + else { + /* + * If there might be a variable reference, note that it + * must be dereferenced. Otherwise decide whether the + * argument location can be used for both the dereferenced + * and undereferenced parameter. + */ + symtab[i].loc = arg_rslt; + if (maybe_var[j]) + symtab[i].adjust = AdjNDrf; + else if (symtab[i - 1].n_mods + symtab[i].n_mods == 0) + symtab[i].adjust = AdjNone; + else + symtab[i].adjust = AdjCpy; + } + } + } + ++i; + } + + /* + * Fill out parameter list with null values. + */ + while (j < nparms) { + int k, kn; + kn = 0; + if (impl->arg_flgs[j] & RtParm) + ++kn; + if (impl->arg_flgs[j] & DrfPrm) + ++kn; + for (k = 0; k < kn; ++k) { + if (symtab[i].n_refs + symtab[i].n_mods > 0) { + arg_rslt = chk_alc(NULL, n->intrnl_lftm); + cd_add(asgn_null(arg_rslt)); + symtab[i].loc = arg_rslt; + } + symtab[i].adjust = AdjNone; + ++i; + } + ++j; + } + + if (var_args) { + /* + * Compute variable part of argument list. + */ + ++nparms; /* add varargs parameter back into parameter list */ + + /* + * The variable part of the parameter list must be in contiguous + * descriptors. Create location and lifetime arrays for use in + * allocating the descriptors. + */ + if (n_varargs > 0) { + varg_rslt = (struct val_loc **)alloc((unsigned int)(n_varargs * + sizeof(struct val_loc *))); + lifetm_ary = alc_lftm(n_varargs, NULL); + } + + flag = impl->arg_flgs[j] & (RtParm | DrfPrm); + + /* + * Compute the lifetime of the elements of the varargs parameter array. + */ + for (v = 0; v < n_varargs; ++v) { + /* + * Use information from type inferencing to determine if the + * argument might me a variable and whether it is a single + * known named variable. + */ + maybe_var[j + v] = HasVar(varsubtyp( + n->n_field[FrstArg+j+v].n_ptr->type, &(single[j + v]))); + + /* + * Determine if the elements of the vararg parameter array + * might be modified. If it is a variable, dereferencing + * modifies it. + */ + may_mod = (symtab[j].n_mods != 0); + if (flag == DrfPrm) + may_mod |= maybe_var[j + v]; + + if ((flag == DrfPrm && single[j + v] != NULL) || + (n->n_field[FrstArg + j + v].n_ptr->reuse && may_mod)) { + /* + * The argument value is only placed in the vararg parameter + * array during "dereferencing". So the lifetime of the array + * element is the lifetime of the parameter and the element + * is not used until dereferencing. + */ + lifetm_ary[v].lifetime = n->intrnl_lftm; + lifetm_ary[v].cur_status = n->postn; + } + else { + /* + * The argument is computed into the vararg parameter array. + * The lifetime of the array element encompasses both + * the lifetime of the argument and the parameter. The + * element is used as soon as the argument is computed. + */ + lifetm_ary[v].lifetime = max_lftm(n->intrnl_lftm, + n->n_field[FrstArg+j+v].n_ptr->lifetime); + lifetm_ary[v].cur_status = n->n_field[FrstArg+j+v].n_ptr->postn; + } + } + + /* + * Allocate (reserve) the array of temporary variables for the + * vararg list. + */ + if (n_varargs > 0) { + arg_loc = alc_tmp(n_varargs, lifetm_ary); + free((char *)lifetm_ary); + } + + /* + * Generate code to compute arguments. + */ + for (v = 0; v < n_varargs; ++v) { + may_mod = (symtab[j].n_mods != 0); + if (flag == DrfPrm) + may_mod |= maybe_var[j + v]; + if (flag == DrfPrm && single[j + v] != NULL) { + /* + * We need a dereferenced value and it is in a known place: a + * named variable; don't bother saving the result of the + * argument computation. + */ + r = &ignore; + } + else if (n->n_field[FrstArg + j + v].n_ptr->reuse && may_mod) { + /* + * The argument can be reused without being recomputed and + * the parameter may be modified, so we cannot safely + * compute the argument into the vararg parameter array; we + * must compute it elsewhere and copy (dereference) it at the + * beginning of the operation. Let gencode allocate an argument + * result location. + */ + r = NULL; + } + else { + /* + * We can compute the argument directly into the vararg + * parameter array. + */ + r = tmp_loc(arg_loc + v); + } + varg_rslt[v] = gencode(n->n_field[FrstArg + j + v].n_ptr, r); + } + + setloc(n); + /* + * Dereference or copy argument values that are not already in vararg + * parameter list. Preceding arguments are dereferenced later, but + * it is okay if dereferencing is out-of-order. + */ + for (v = 0; v < n_varargs; ++v) { + if (flag == DrfPrm && single[j + v] != NULL) { + /* + * Copy the value from the known named variable into the + * parameter list. + */ + varg_rslt[v] = var_ref(single[j + v]); + cd_add(mk_cpyval(tmp_loc(arg_loc + v), varg_rslt[v])); + } + else if (flag == DrfPrm && maybe_var[j + v]) { + /* + * Dereference the argument into the parameter list. + */ + deref_cd(varg_rslt[v], tmp_loc(arg_loc + v)); + } + else if (arg_loc + v != varg_rslt[v]->u.tmp) { + /* + * The argument is a dereferenced value, but is not yet + * in the parameter list; copy it there. + */ + cd_add(mk_cpyval(tmp_loc(arg_loc + v), varg_rslt[v])); + } + tmp_status[arg_loc + v] = InUse; /* parameter location in use */ + } + + /* + * The vararg parameter gets the address of the first element + * in the variable part of the argument list and the size + * parameter gets the number of elements in the list. + */ + if (n_varargs > 0) { + free((char *)varg_rslt); + symtab[i].loc = tmp_loc(arg_loc); + } + else + symtab[i].loc = chk_alc(NULL, n); /* dummy arg location */ + symtab[i].loc->mod_access = M_Addr; + ++i; + symtab[i].loc = vararg_sz(n_varargs); + ++i; + } + else { + /* + * Compute extra arguments, but discard the results. + */ + while (j < nargs) { + gencode(n->n_field[FrstArg + j].n_ptr, &ignore); + ++j; + } + } + + if (nargs > 0) { + free((char *)maybe_var); + free((char *)single); + } + + /* + * If execution does not continue through the parameter evaluation, + * don't try to generate in-line code. A lack of parameter types + * will cause problems with some in-line type conversions. + */ + if (!past_prms(n)) + return rslt; + + setloc(n); + + dcl_var = i; + + /* + * Perform any needed copying or dereferencing. + */ + for (i = 0; i < nsyms; ++i) { + switch (symtab[i].adjust) { + case AdjNDrf: + /* + * Dereference into a new temporary which is used as the + * parameter. + */ + arg_rslt = chk_alc(NULL, n->intrnl_lftm); + deref_cd(symtab[i].loc, arg_rslt); + symtab[i].loc = arg_rslt; + break; + case AdjDrf: + /* + * Dereference in place. + */ + deref_cd(symtab[i].loc, symtab[i].loc); + break; + case AdjCpy: + /* + * Copy into a new temporary which is used as the + * parameter. + */ + arg_rslt = chk_alc(NULL, n->intrnl_lftm); + cd_add(mk_cpyval(arg_rslt, symtab[i].loc)); + symtab[i].loc = arg_rslt; + break; + case AdjNone: + break; /* nothing need be done */ + } + } + + switch (cont_loc) { + case SepFnc: + /* + * success continuation must be in a separate function. + */ + fnc = alc_fnc(); + sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); + sprintf(sbuf, "end %s", impl->name); + scont_strt = alc_lbl(sbuf, 0); + cd_add(scont_strt); + cur_fnc->cursor = scont_strt->prev; /* put oper before label */ + gen_inlin(impl->in_line, rslt, &scont_strt, NULL, fnc, impl, + nsyms, symtab, n, dcl_var, n_varargs); + cur_fnc->cursor = scont_strt; + callc_add(fnc); + cur_fnc = fnc; + on_failure = &resume; + break; + case SContIL: + /* + * one suspend an no return: success continuation is put in-line. + */ + gen_inlin(impl->in_line, rslt, &scont_strt, &scont_fail, NULL, impl, + nsyms, symtab, n, dcl_var, n_varargs); + cur_fnc->cursor = scont_strt; + on_failure = scont_fail; + break; + case EndOper: + /* + * no suspends: success continuation goes at end of operation. + */ + + sbuf = (char *)alloc((unsigned int)(strlen(impl->name) + 5)); + sprintf(sbuf, "end %s", impl->name); + scont_strt = alc_lbl(sbuf, 0); + cd_add(scont_strt); + cur_fnc->cursor = scont_strt->prev; /* put operation before lbl */ + gen_inlin(impl->in_line, rslt, &scont_strt, NULL, NULL, impl, + nsyms, symtab, n, dcl_var, n_varargs); + cur_fnc->cursor = scont_strt; + break; + } + } + else { + /* + * Do not in-line operation. + */ + implproto(impl); + frst_arg = gen_args(n, 2, nargs); + setloc(n); + if (impl->ret_flag & (DoesRet | DoesSusp)) + rslt = chk_alc(rslt, rslt_lftm); + mk_callop(oper_name(impl), impl->ret_flag, frst_arg, nargs, rslt, + 0); + } + if (symtab != NULL) + free((char *)symtab); + return rslt; + } + +/* + * max_lftm - given two lifetimes (in the form of nodes) return the + * maximum one. + */ +static nodeptr max_lftm(n1, n2) +nodeptr n1; +nodeptr n2; + { + if (n1 == NULL) + return n2; + else if (n2 == NULL) + return n1; + else if (n1->postn > n2->postn) + return n1; + else + return n2; + } + +/* + * inv_prc - directly invoke a procedure. + */ +static struct val_loc *inv_prc(n, rslt) +nodeptr n; +struct val_loc *rslt; + { + struct pentry *proc; + struct val_loc *r; + struct val_loc *arg1rslt; + struct val_loc *var_part; + int *must_deref; + struct lentry **single; + struct val_loc **arg_rslt; + struct code *cd; + struct tmplftm *lifetm_ary; + char *sbuf; + int nargs; + int nparms; + int i, j; + int arg_loc; + int var_sz; + int var_loc; + + /* + * This procedure is implemented without argument list adjustment or + * dereferencing, so they must be done before the call. + */ + nargs = Val0(n); /* number of arguments */ + proc = Proc1(n); + nparms = Abs(proc->nargs); + + if (nparms > 0) { + must_deref = (int *)alloc((unsigned int)(nparms * sizeof(int))); + single = (struct lentry **)alloc((unsigned int)(nparms * + sizeof(struct lentry *))); + arg_rslt = (struct val_loc **)alloc((unsigned int)(nparms * + sizeof(struct val_loc *))); + } + + /* + * Allocate a work area of temporaries to use as argument list. If + * an argument can be reused without being recomputed, it must not + * be computed directly into the work area. It will be copied or + * dereferenced into the work area when execution reaches the + * operation. If an argument is a single named variable, it can + * be dereferenced directly into the argument location. These + * conditions affect when the temporary will receive a value. + */ + if (nparms > 0) + lifetm_ary = alc_lftm(nparms, NULL); + for (i = 0; i < nparms; ++i) + lifetm_ary[i].lifetime = n->intrnl_lftm; + for (i = 0; i < nparms && i < nargs; ++i) { + must_deref[i] = HasVar(varsubtyp(n->n_field[FrstArg + i].n_ptr->type, + &(single[i]))); + if (single[i] != NULL || n->n_field[FrstArg + i].n_ptr->reuse) + lifetm_ary[i].cur_status = n->postn; + else + lifetm_ary[i].cur_status = n->n_field[FrstArg + i].n_ptr->postn; + } + while (i < nparms) { + lifetm_ary[i].cur_status = n->postn; /* arg list extension */ + ++i; + } + if (proc->nargs < 0) + lifetm_ary[nparms - 1].cur_status = n->postn; /* variable part */ + + if (nparms > 0) { + arg_loc = alc_tmp(nparms, lifetm_ary); + free((char *)lifetm_ary); + } + if (proc->nargs < 0) + --nparms; /* treat variable part specially */ + for (i = 0; i < nparms && i < nargs; ++i) { + if (single[i] != NULL) + r = &ignore; /* we know where the dereferenced value is */ + else if (n->n_field[FrstArg + i].n_ptr->reuse) + r = NULL; /* let gencode allocate a new temporary */ + else + r = tmp_loc(arg_loc + i); + arg_rslt[i] = gencode(n->n_field[FrstArg + i].n_ptr, r); + } + + /* + * If necessary, fill out argument list with nulls. + */ + while (i < nparms) { + cd_add(asgn_null(tmp_loc(arg_loc + i))); + tmp_status[arg_loc + i] = InUse; + ++i; + } + + if (proc->nargs < 0) { + /* + * handle variable part of list. + */ + var_sz = nargs - nparms; + + if (var_sz > 0) { + lifetm_ary = alc_lftm(var_sz, &n->n_field[FrstArg + nparms]); + var_loc = alc_tmp(var_sz, lifetm_ary); + free((char *)lifetm_ary); + for (j = 0; j < var_sz; ++j) { + gencode(n->n_field[FrstArg + nparms + j].n_ptr, + tmp_loc(var_loc + j)); + } + } + } + else { + /* + * If there are extra arguments, compute them, but discard the + * results. + */ + while (i < nargs) { + gencode(n->n_field[FrstArg + i].n_ptr, &ignore); + ++i; + } + } + + setloc(n); + /* + * Dereference or copy argument values that are not already in argument + * list as dereferenced values. + */ + for (i = 0; i < nparms && i < nargs; ++i) { + if (must_deref[i]) { + if (single[i] == NULL) { + deref_cd(arg_rslt[i], tmp_loc(arg_loc + i)); + } + else { + arg_rslt[i] = var_ref(single[i]); + cd_add(mk_cpyval(tmp_loc(arg_loc + i), arg_rslt[i])); + } + } + else if (n->n_field[FrstArg + i].n_ptr->reuse) + cd_add(mk_cpyval(tmp_loc(arg_loc + i), arg_rslt[i])); + tmp_status[arg_loc + i] = InUse; + } + + if (proc->nargs < 0) { + var_part = tmp_loc(arg_loc + nparms); + tmp_status[arg_loc + nparms] = InUse; + if (var_sz <= 0) { + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "varargs(NULL, 0, &"; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = var_part; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ");"; + } + else { + cd = alc_ary(7); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "varargs(&"; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = tmp_loc(var_loc); + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ", "; + cd->ElemTyp(3) = A_Intgr; + cd->Intgr(3) = var_sz; + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ", &"; + cd->ElemTyp(5) = A_ValLoc; + cd->ValLoc(5) = var_part; + cd->ElemTyp(6) = A_Str; + cd->Str(6) = ");"; + } + cd_add(cd); + ++nparms; /* include variable part in call */ + } + + if (nparms > 0) { + free((char *)must_deref); + free((char *)single); + free((char *)arg_rslt); + } + + sbuf = (char *)alloc((unsigned int)(strlen(proc->name) + PrfxSz + 3)); + sprintf(sbuf, "P%s_%s", proc->prefix, proc->name); + if (nparms > 0) + arg1rslt = tmp_loc(arg_loc); + else + arg1rslt = NULL; + if (proc->ret_flag & (DoesRet | DoesSusp)) + rslt = chk_alc(rslt, n->lifetime); + mk_callop(sbuf, proc->ret_flag, arg1rslt, nargs, rslt, 1); + return rslt; + } + +/* + * endlife - link a temporary variable onto the list to be freed when + * execution reaches a node. + */ +static void endlife(kind, indx, old, n) +int kind; +int indx; +int old; +nodeptr n; + { + struct freetmp *freetmp; + + if ((freetmp = freetmp_pool) == NULL) + freetmp = NewStruct(freetmp); + else + freetmp_pool = freetmp_pool->next; + freetmp->kind = kind; + freetmp->indx = indx; + freetmp->old = old; + freetmp->next = n->freetmp; + n->freetmp = freetmp; + } + +/* + * alc_tmp - allocate a block of temporary variables with the given lifetimes. + */ +static int alc_tmp(num, lifetm_ary) +int num; +struct tmplftm *lifetm_ary; + { + int i, j, k; + register int status; + int *new_status; + int new_size; + + i = 0; + for (;;) { + if (i + num > status_sz) { + /* + * The status array is too small, expand it. + */ + new_size = status_sz + Max(num, status_sz); + new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); + k = 0; + while (k < status_sz) { + new_status[k] = tmp_status[k]; + ++k; + } + while (k < new_size) { + new_status[k] = NotAlloc; + ++k; + } + free((char *)tmp_status); + tmp_status = new_status; + status_sz = new_size; + } + for (j = 0; j < num; ++j) { + status = tmp_status[i + j]; + if (status != NotAlloc && + (status == InUse || status <= lifetm_ary[j].lifetime->postn)) + break; + } + /* + * Did we find a block of temporaries that we can use? + */ + if (j == num) { + while (--j >= 0) { + endlife(DescTmp, i + j, tmp_status[i + j], lifetm_ary[j].lifetime); + tmp_status[i + j] = lifetm_ary[j].cur_status; + } + if (i + num > num_tmp) + num_tmp = i + num; + return i; + } + ++i; + } + } + +/* + * alc_lftm - allocate an array of lifetime information for an argument + * list. + */ +static struct tmplftm *alc_lftm(num, args) +int num; +union field *args; + { + struct tmplftm *lifetm_ary; + int i; + + lifetm_ary = (struct tmplftm *)alloc((unsigned int)(num * + sizeof(struct tmplftm))); + if (args != NULL) + for (i = 0; i < num; ++i) { + lifetm_ary[i].cur_status = args[i].n_ptr->postn; /* reserved for arg */ + lifetm_ary[i].lifetime = args[i].n_ptr->lifetime; + } + return lifetm_ary; + } + +/* + * alc_itmp - allocate a temporary C integer variable. + */ +int alc_itmp(lifetime) +nodeptr lifetime; + { + int i, j; + int new_size; + + i = 0; + while (i < istatus_sz && itmp_status[i] == InUse) + ++i; + if (i >= istatus_sz) { + /* + * The status array is too small, expand it. + */ + free((char *)itmp_status); + new_size = istatus_sz * 2; + itmp_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); + j = 0; + while (j < istatus_sz) + itmp_status[j++] = InUse; + while (j < new_size) + itmp_status[j++] = NotAlloc; + istatus_sz = new_size; + } + endlife(CIntTmp, i, NotAlloc, lifetime); + itmp_status[i] = InUse; + if (num_itmp < i + 1) + num_itmp = i + 1; + return i; + } + +/* + * alc_dtmp - allocate a temporary C integer variable. + */ +int alc_dtmp(lifetime) +nodeptr lifetime; + { + int i, j; + int new_size; + + i = 0; + while (i < dstatus_sz && dtmp_status[i] == InUse) + ++i; + if (i >= dstatus_sz) { + /* + * The status array is too small, expand it. + */ + free((char *)dtmp_status); + new_size = dstatus_sz * 2; + dtmp_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); + j = 0; + while (j < dstatus_sz) + dtmp_status[j++] = InUse; + while (j < new_size) + dtmp_status[j++] = NotAlloc; + dstatus_sz = new_size; + } + endlife(CDblTmp, i, NotAlloc, lifetime); + dtmp_status[i] = InUse; + if (num_dtmp < i + 1) + num_dtmp = i + 1; + return i; + } + +/* + * alc_sbufs - allocate a block of string buffers with the given lifetime. + */ +int alc_sbufs(num, lifetime) +int num; +nodeptr lifetime; + { + int i, j, k; + int *new_status; + int new_size; + + i = 0; + for (;;) { + if (i + num > sstatus_sz) { + /* + * The status array is too small, expand it. + */ + new_size = sstatus_sz + Max(num, sstatus_sz); + new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); + k = 0; + while (k < sstatus_sz) { + new_status[k] = sbuf_status[k]; + ++k; + } + while (k < new_size) { + new_status[k] = NotAlloc; + ++k; + } + free((char *)sbuf_status); + sbuf_status = new_status; + sstatus_sz = new_size; + } + for (j = 0; j < num && sbuf_status[i + j] == NotAlloc; ++j) + ; + /* + * Did we find a block of buffers that we can use? + */ + if (j == num) { + while (--j >= 0) { + endlife(SBuf, i + j, sbuf_status[i + j], lifetime); + sbuf_status[i + j] = InUse; + } + if (i + num > num_sbuf) + num_sbuf = i + num; + return i; + } + ++i; + } + } + +/* + * alc_cbufs - allocate a block of cset buffers with the given lifetime. + */ +int alc_cbufs(num, lifetime) +int num; +nodeptr lifetime; + { + int i, j, k; + int *new_status; + int new_size; + + i = 0; + for (;;) { + if (i + num > cstatus_sz) { + /* + * The status array is too small, expand it. + */ + new_size = cstatus_sz + Max(num, cstatus_sz); + new_status = (int *)alloc((unsigned int)(new_size * sizeof(int))); + k = 0; + while (k < cstatus_sz) { + new_status[k] = cbuf_status[k]; + ++k; + } + while (k < new_size) { + new_status[k] = NotAlloc; + ++k; + } + free((char *)cbuf_status); + cbuf_status = new_status; + cstatus_sz = new_size; + } + for (j = 0; j < num && cbuf_status[i + j] == NotAlloc; ++j) + ; + /* + * Did we find a block of buffers that we can use? + */ + if (j == num) { + while (--j >= 0) { + endlife(CBuf, i + j, cbuf_status[i + j], lifetime); + cbuf_status[i + j] = InUse; + } + if (i + num > num_cbuf) + num_cbuf = i + num; + return i; + } + ++i; + } + } diff --git a/src/iconc/ccode.h b/src/iconc/ccode.h new file mode 100644 index 0000000..2d0cb6f --- /dev/null +++ b/src/iconc/ccode.h @@ -0,0 +1,252 @@ +/* + * ccode.h - definitions used in code generation. + */ + +/* + * ChkPrefix - allocate a prefix to x if it has not already been done. + */ +#define ChkPrefix(x) if ((x)[0] == '\0') nxt_pre(x, pre, PrfxSz); + +/* + * sig_act - list of possible signals returned by a call and the action to be + * to be taken when the signal is returned: in effect a switch statement. + */ +struct sig_act { + struct code *sig; /* signal */ + struct code *cd; /* action to be taken: goto, return, break */ + struct sig_act *shar_act; /* signals that share this action */ + struct sig_act *next; + }; + +/* + * val_loc - location of a value. Used for intermediate and final results + * of expressions. + */ +#define V_NamedVar 1 /* Icon named variable indicated by nvar */ +#define V_Temp 2 /* temporary variable indicated by tmp */ +#define V_ITemp 3 /* C integer temporary variable indicated by tmp */ +#define V_DTemp 4 /* C double temporary variable indicated by tmp */ +#define V_PRslt 5 /* procedure result location */ +#define V_Const 6 /* integer constant - used for size of varargs */ +#define V_CVar 7 /* C named variable */ +#define V_Ignore 8 /* "trashcan" - a write-only location */ + +#define M_None 0 /* access simply as descriptor */ +#define M_CharPtr 1 /* access v-word as "char *" */ +#define M_BlkPtr 2 /* access v-word as block pointer using blk_name */ +#define M_CInt 3 /* access v-word as C integer */ +#define M_Addr 4 /* address of descriptor for varargs */ + +struct val_loc { + int loc_type; /* manifest constants V_* */ + int mod_access; /* manifest constants M_* */ + char *blk_name; /* used with M_BlkPtr */ + union { + struct lentry *nvar; /* Icon named variable */ + int tmp; /* index of temporary variable */ + int int_const; /* integer constant value */ + char *name; /* C named variable */ + } u; + }; + +/* + * "code" contains the information needed to print a piece of C code. + * C_... manifest constants are cd_id's. These are followed by + * corresponding field access expressions. + */ +#define Rslt fld[0].vloc /* place to put result of expression */ +#define Cont fld[1].fnc /* continuation function or null */ + +#define C_Null 0 /* no code */ + +#define C_NamedVar 1 /* reference to a named variable */ +/* uses Rslt */ +#define NamedVar fld[1].nvar + +#define C_CallSig 2 /* call and handling of returned signal */ +#define OperName fld[0].oper_nm /* run-time routine name or null */ +/* uses Cont */ +#define Flags fld[2].n /* flag: NeedCont, ForeignSig */ +#define ArgLst fld[3].cd /* argument list */ +#define ContFail fld[4].cd /* label/signal to goto/return on failure */ +#define SigActs fld[5].sa /* actions to take for returned signals */ +#define NextCall fld[6].cd /* for chaining calls within a continuation*/ +#define NeedCont 1 /* pass NULL continuation if Cont == NULL */ +#define ForeignSig 2 /* may get foreign signal from a suspend */ + +#define C_RetSig 3 /* return signal */ +#define SigRef fld[0].sigref /* pointer to func's reference to signal */ + +#define C_Goto 4 /* goto label */ +#define Lbl fld[0].cd /* label */ + +#define C_Label 5 /* statment label "Ln:" and signal "n" */ +#define Container fld[0].fnc /* continuation containing label */ +#define SeqNum fld[1].n /* sequence number, n */ +#define Desc fld[2].s /* description of how label/signal is used */ +#define RefCnt fld[3].n /* reference count for label */ +#define LabFlg fld[4].n /* flag: FncPtrd, BndSig */ +#define FncPrtd 1 /* function sig_n has been printed */ +#define Bounding 2 /* this is a bounding label */ + +#define C_Lit 6 /* literal (integer, real, string, cset) */ +/* uses Rslt */ +#define Literal fld[1].lit + +#define C_Resume 7 /* resume signal */ +#define C_Continue 8 /* continue signal */ +#define C_FallThru 9 /* fall through signal */ +#define C_PFail 10 /* procedure failure */ +#define C_PRet 11 /* procedure return (result already set) */ +#define C_PSusp 12 /* procedure suspend */ +#define C_Break 13 /* break out of signal handling switch */ +#define C_LBrack 14 /* '{' */ +#define C_RBrack 15 /* '}' */ + +#define C_Create 16 /* call of create() for create expression */ +/* uses Rslt */ +/* uses Cont */ +#define NTemps fld[2].n /* number of temporary descriptors needed */ +#define WrkSize fld[3].n /* size of non-descriptor work area */ +#define NextCreat fld[4].cd /* for chaining creates in a continuation */ + + +#define C_If 17 /* conditional (goto or return) */ +#define Cond fld[0].cd /* condition */ +#define ThenStmt fld[1].cd /* what to do if condition is true */ + +#define C_SrcLoc 18 +#define FileName fld[0].s /* name of source file */ +#define LineNum fld[1].n /* line number within source file */ + +#define C_CdAry 19 /* array of code pieces, each with type code*/ +#define A_Str 0 /* code represented as a string */ +#define A_ValLoc 1 /* value location */ +#define A_Intgr 2 /* integer */ +#define A_ProcCont 3 /* procedure continuation */ +#define A_SBuf 4 /* string buffer (integer index) */ +#define A_CBuf 5 /* cset buffer (integer index) */ +#define A_Ary 6 /* pointer to subarray of code pieces */ +#define A_End 7 /* marker for end of array */ +#define ElemTyp(i) fld[2*i].n /* type of element i (A_* codes) */ +#define Str(i) fld[2*i+1].s /* string in element i */ +#define ValLoc(i) fld[2*i+1].vloc /* value location in element i */ +#define Intgr(i) fld[2*i+1].n /* integer in element i */ +#define Array(i) fld[2*i+1].cd /* pointer to subarray in element i */ + +/* + * union cd_fld - fields within a code struct. + */ +union cd_fld { + int n; /* various integer values */ + char *s; /* various string values */ + struct lentry *nvar; /* symbol table entry for a named variable */ + struct code *cd; /* various pointers to other pieces of code */ + struct c_fnc *fnc; /* pointer to function information */ + struct centry *lit; /* symbol table entry for a literal */ + struct sig_act *sa; /* actions to take for a returned signal */ + struct sig_lst *sigref; /* pointer to func's reference to signal */ + struct val_loc *vloc; /* value location */ + char *oper_nm; /* name of run-time operation or NULL */ + }; + +/* + * code - struct used to hold the internal representation of generated code. + */ +struct code { + int cd_id; /* kind of code: C_* */ + struct code *next; /* next code fragment in list */ + struct code *prev; /* previous code fragment in list */ + union cd_fld fld[1]; /* fields of code fragment, actual number varies */ + }; + +/* + * NewCode - allocate a code structure with "size" fields. + */ +#define NewCode(size) (struct code *)alloc((unsigned int)\ + (sizeof(struct code) + (size-1) * sizeof(union cd_fld))) + +/* + * c_fnc contains information about a C function that implements a continuation. + */ +#define CF_SigOnly 1 /* this function only returns a signal */ +#define CF_ForeignSig 2 /* may return foreign signal from a suspend */ +#define CF_Mark 4 /* this function has been visited by fix_fncs() */ +#define CF_Coexpr 8 /* this function implements a co-expression */ +struct c_fnc { + char prefix[PrfxSz+1]; /* function prefix */ + char frm_prfx[PrfxSz+1]; /* procedure frame prefix */ + int flag; /* CF_* flags */ + struct code cd; /* start of code sequence */ + struct code *cursor; /* place to insert more code into sequence */ + struct code *call_lst; /* functions called by this function */ + struct code *creatlst; /* list of creates in this function */ + struct sig_lst *sig_lst; /* signals returned by this function */ + int ref_cnt; /* reference count for this function */ + struct c_fnc *next; + }; + + +/* + * sig_lst - a list of signals returned by a continuation along with a count + * of the number of places each signal is returned. + */ +struct sig_lst { + struct code *sig; /* signal */ + int ref_cnt; /* number of places returned */ + struct sig_lst *next; + }; + +/* + * op_symentry - entry in symbol table for an operation + */ +#define AdjNone 1 /* no adjustment to this argument */ +#define AdjDrf 2 /* deref in place */ +#define AdjNDrf 3 /* deref into a new temporary */ +#define AdjCpy 4 /* copy into a new temporary */ +struct op_symentry { + int n_refs; /* number of non-modifying references */ + int n_mods; /* number of modifying referenced */ + int n_rets; /* number of times directly returned from operation */ + int var_safe; /* if arg is named var, it may be used directly */ + int adjust; /* AdjNone, AdjInplc, or AdjToNew */ + int itmp_indx; /* index of temporary C integer variable */ + int dtmp_indx; /* index of temporary C double variable */ + struct val_loc *loc; + }; + +extern int num_tmp; /* number of temporary descriptor variables */ +extern int num_itmp; /* number of temporary C integer variables */ +extern int num_dtmp; /* number of temporary C double variables */ +extern int num_sbuf; /* number of string buffers */ +extern int num_cbuf; /* number of cset buffers */ + +extern struct code *bound_sig; /* bounding signal for current procedure */ + +/* + * statically declared "signals". + */ +extern struct code resume; +extern struct code contin; +extern struct code fallthru; +extern struct code next_fail; + +extern struct val_loc ignore; /* no values, just something to point at */ +extern struct c_fnc *cur_fnc; /* C function currently being built */ +extern struct code *on_failure; /* place to go on failure */ + +extern int lbl_seq_num; /* next label sequence number */ + +extern char pre[PrfxSz]; /* next unused prefix */ + +extern struct op_symentry *cur_symtab; /* current operation symbol table */ + +#define SepFnc 1 /* success continuation goes in separate function */ +#define SContIL 2 /* in line success continuation */ +#define EndOper 3 /* success continuation goes at end of operation */ + +#define HasVal 1 /* type contains values */ +#define HasLcl 2 /* type contains local variables */ +#define HasPrm 4 /* type contains parameters */ +#define HasGlb 8 /* type contains globals (including statics and elements) */ +#define HasVar(x) ((x) & (HasLcl | HasPrm | HasGlb)) diff --git a/src/iconc/ccomp.c b/src/iconc/ccomp.c new file mode 100644 index 0000000..5b86189 --- /dev/null +++ b/src/iconc/ccomp.c @@ -0,0 +1,130 @@ +/* + * ccomp.c - routines for compiling and linking the C program produced + * by the translator. + */ +#include "../h/gsupport.h" +#include "cglobals.h" +#include "ctrans.h" +#include "ctree.h" +#include "ccode.h" +#include "csym.h" +#include "cproto.h" + +extern char *refpath; + +#define ExeFlag "-o" +#define LinkLibs " -lm" + +/* + * Structure to hold the list of Icon run-time libraries that must be + * linked in. + */ +struct lib { + char *libname; + int nm_sz; + struct lib *next; + }; +static struct lib *liblst; +static int lib_sz = 0; + +/* + * addlib - add a new library to the list the must be linked. + */ +void addlib(libname) +char *libname; + { + static struct lib **nxtlib = &liblst; + struct lib *l; + + l = NewStruct(lib); + l->libname = libname; + l->nm_sz = strlen(libname); + l->next = NULL; + *nxtlib = l; + nxtlib = &l->next; + lib_sz += l->nm_sz + 1; + } + +/* + * ccomp - perform C compilation and linking. + */ +int ccomp(srcname, exename) +char *srcname; +char *exename; + { + struct lib *l; + char sbuf[MaxPath]; /* file name construction buffer */ + char *buf; + char *s; + char *dlrgint; + int cmd_sz, opt_sz, flg_sz, exe_sz, src_sz; + + /* + * Compute the sizes of the various parts of the command line + * to do the compilation. + */ + cmd_sz = strlen(c_comp); + opt_sz = strlen(c_opts); + flg_sz = strlen(ExeFlag); + exe_sz = strlen(exename); + src_sz = strlen(srcname); + lib_sz += strlen(LinkLibs); + if (!largeints) { + dlrgint = makename(sbuf, refpath, "dlrgint", ObjSuffix); + lib_sz += strlen(dlrgint) + 1; + } + +#ifdef Graphics + lib_sz += strlen(" -L") + + strlen(refpath) + + strlen(" -lIgpx "); + lib_sz += strlen(ICONC_XLIB); +#endif /* Graphics */ + + buf = alloc((unsigned int)cmd_sz + opt_sz + flg_sz + exe_sz + src_sz + + lib_sz + 5); + strcpy(buf, c_comp); + s = buf + cmd_sz; + *s++ = ' '; + strcpy(s, c_opts); + s += opt_sz; + *s++ = ' '; + strcpy(s, ExeFlag); + s += flg_sz; + *s++ = ' '; + strcpy(s, exename); + s += exe_sz; + *s++ = ' '; + strcpy(s, srcname); + s += src_sz; + if (!largeints) { + *s++ = ' '; + strcpy(s, dlrgint); + s += strlen(dlrgint); + } + for (l = liblst; l != NULL; l = l->next) { + *s++ = ' '; + strcpy(s, l->libname); + s += l->nm_sz; + } + +#ifdef Graphics + strcpy(s," -L"); + strcat(s, refpath); + strcat(s," -lIgpx "); + strcat(s, ICONC_XLIB); + s += strlen(s); +#endif /* Graphics */ + + strcpy(s, LinkLibs); + + if (system(buf) != 0) + return EXIT_FAILURE; + strcpy(buf, "strip "); + s = buf + 6; + strcpy(s, exename); + system(buf); + + + return EXIT_SUCCESS; + } diff --git a/src/iconc/cglobals.h b/src/iconc/cglobals.h new file mode 100644 index 0000000..301a602 --- /dev/null +++ b/src/iconc/cglobals.h @@ -0,0 +1,50 @@ +/* + * Global variables. + */ + +extern char *runtime; + +#ifndef Global +#define Global extern +#define Init(v) +#endif /* Global */ + +/* + * Variables related to command processing. + */ +Global char *progname Init("iconc"); /* program name for diagnostics */ + +Global int debug_info Init(0); /* -fd, -t: generate debugging info */ +Global int err_conv Init(0); /* -fe: support error conversion */ + +#ifdef LargeInts + Global int largeints Init(1); /* -fl: support large integers */ +#else /* LargeInts */ + Global int largeints Init(0); /* -fl: support large integers */ +#endif /* LargeInts */ + +Global int line_info Init(0); /* -fn, -fd, -t: generate line info */ +Global int m4pre Init(0); /* -m: use m4 preprocessor? */ +Global int str_inv Init(0); /* -fs: enable full string invocation */ +Global int trace Init(0); /* -t: initial &trace value */ +Global int uwarn Init(0); /* -u: warn about undefined ids? */ +Global int just_type_trace Init(0); /* -T: suppress C code */ +Global int verbose Init(1); /* -s, -v: level of verbosity */ +Global int pponly Init(0); /* -E: preprocess only */ + +Global char *c_comp Init(CComp); /* -C: C compiler */ +Global char *c_opts Init(COpts); /* -p: options for C compiler */ + +/* + * Flags turned off by the -n option. + */ +Global int opt_cntrl Init(1); /* do control flow optimization */ +Global int opt_sgnl Init(1); /* do signal handling optimizations */ +Global int do_typinfer Init(1); /* do type inference */ +Global int allow_inline Init(1); /* allow expanding operations in line */ + +/* + * Files. + */ +Global FILE *codefile Init(0); /* C code output - primary file */ +Global FILE *inclfile Init(0); /* C code output - include file */ diff --git a/src/iconc/cgrammar.c b/src/iconc/cgrammar.c new file mode 100644 index 0000000..a48e621 --- /dev/null +++ b/src/iconc/cgrammar.c @@ -0,0 +1,221 @@ +/* + * cgrammar.c - includes and macros for building the parse tree. + */ +#include "../h/define.h" +#include "../common/yacctok.h" + +%{ +/* + * These commented directives are passed through the first application + * of cpp, then turned into real directives in cgram.g by fixgram.icn. + */ +/*#include "../h/gsupport.h"*/ +/*#include "../h/lexdef.h"*/ +/*#include "ctrans.h"*/ +/*#include "csym.h"*/ +/*#include "ctree.h"*/ +/*#include "ccode.h" */ +/*#include "cproto.h"*/ +/*#undef YYSTYPE*/ +/*#define YYSTYPE nodeptr*/ +/*#define YYMAXDEPTH 500*/ + +int idflag; + +#define EmptyNode tree1(N_Empty) + +#define Alt(x1,x2,x3) $$ = tree4(N_Alt,x2,x1,x3) +#define Apply(x1,x2,x3) $$ = tree4(N_Apply,x2,x1,x3) +#define Arglist1() /* empty */ +#define Arglist2(x) /* empty */ +#define Arglist3(x1,x2,x3) proc_lst->nargs = -proc_lst->nargs +#define Bact(x1,x2,x3) $$ = tree5(N_Activat,x2,x2,x1,x3) +#define Bamper(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bassgn(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Baugact(x1,x2,x3) $$ = tree5(N_Activat,x2,x2,x1,x3) +#define Baugamper(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugcat(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugeq(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugeqv(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugge(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Bauggt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Bauglcat(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugle(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Bauglt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugne(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugneqv(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugques(x1,x2,x3) $$ = tree5(N_Scan,x2,x2,x1,x3) +#define Baugseq(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugsge(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugsgt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugsle(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugslt(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Baugsne(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Bcaret(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bcareta(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Bcat(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bdiff(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bdiffa(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Beq(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Beqv(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bge(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bgt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Binter(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bintera(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Blcat(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Ble(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Blim(x1,x2,x3) $$ = tree4(N_Limit,x2,x1,x3) +#define Blt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bminus(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bminusa(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Bmod(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bmoda(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Bne(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bneqv(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bplus(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bplusa(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Bques(x1,x2,x3) $$ = tree5(N_Scan,x2,x2,x1,x3) +#define Brace(x1,x2,x3) $$ = x2 +#define Brack(x1,x2,x3) $$ = list_nd(x1,x2) +#define Brassgn(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Break(x1,x2) $$ = tree3(N_Break,x1,x2) +#define Brswap(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bseq(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bsge(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bsgt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bslash(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bslasha(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Bsle(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bslt(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bsne(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bstar(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bstara(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Bswap(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Bunion(x1,x2,x3) $$ = binary_nd(x2,x1,x3) +#define Buniona(x1,x2,x3) $$ = aug_nd(x2,x1,x3) +#define Case(x1,x2,x3,x4,x5,x6) $$ = case_nd(x1,x2,x5) +#define Caselist(x1,x2,x3) $$ = tree4(N_Clist,x2,x1,x3) +#define Cclause0(x1,x2,x3) $$ = tree4(N_Ccls,x2,x1,x3) +#define Cclause1(x1,x2,x3) $$ = tree4(N_Ccls,x2,x1,x3) +#define Cliter(x) CSym0(x) = putlit(Str0(x),F_CsetLit,(int)Val1(x)) +#define Colon(x) $$ = x +#define Compound(x1,x2,x3) $$ = tree4(N_Slist,x2,x1,x3) +#define Create(x1,x2) $$ = tree3(N_Create,x1,x2);\ + proc_lst->has_coexpr = 1; +#define Elst0(x) $$ = x; +#define Elst1(x1,x2,x3) $$ = tree4(N_Elist,x2,x1,x3); +#define Every0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) +#define Every1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) +#define Fail(x) $$ = tree4(N_Ret,x,x,EmptyNode) +#define Field(x1,x2,x3) $$ = tree4(N_Field,x2,x1,x3) +#define Global0(x) idflag = F_Global +#define Global1(x1,x2,x3) /* empty */ +#define Globdcl(x) /* empty */ +#define Ident(x) install(Str0(x),idflag) +#define Idlist(x1,x2,x3) install(Str0(x3),idflag) +#define If0(x1,x2,x3,x4) $$ = tree5(N_If,x1,x2,x4,EmptyNode) +#define If1(x1,x2,x3,x4,x5,x6) $$ = tree5(N_If,x1,x2,x4,x6) +#define Iliter(x) CSym0(x) = putlit(Str0(x),F_IntLit,0) +#define Initial1() $$ = EmptyNode +#define Initial2(x1,x2,x3) $$ = x2 +#define Invocdcl(x) /* empty */ +#define Invocable(x1,x2) /* empty */ +#define Invoclist(x1,x2, x3) /* empty */ +#define Invocop1(x) invoc_grp(Str0(x)); +#define Invocop2(x) invocbl(x, -1); +#define Invocop3(x1,x2,x3) invocbl(x1, atoi(Str0(x3))); +#define Invoke(x1,x2,x3,x4) $$ = invk_nd(x2,x1,x3) +#define Keyword(x1,x2) $$ = key_leaf(x1,Str0(x2)) +#define Kfail(x1,x2) $$ = key_leaf(x1,spec_str("fail")) +#define Link(x1,x2) /* empty */ +#define Linkdcl(x) /* empty */ +#define Lnkfile1(x) lnkdcl(Str0(x)); +#define Lnkfile2(x) lnkdcl(Str0(x)); +#define Lnklist(x1,x2,x3) /* empty */ +#define Local(x) idflag = F_Dynamic +#define Locals1() /* empty */ +#define Locals2(x1,x2,x3,x4) /* empty */ +#define Mcolon(x) $$ = x +#define Nexpr() $$ = EmptyNode +#define Next(x) $$ = tree2(N_Next,x) +#define Paren(x1,x2,x3) if ((x2)->n_type == N_Elist)\ + $$ = invk_nd(x1,EmptyNode,x2);\ + else\ + $$ = x2 +#define Pcolon(x) $$ = x +#define Pdco0(x1,x2,x3) $$ = invk_nd(x2,x1,list_nd(x2,EmptyNode)) +#define Pdco1(x1,x2,x3,x4) $$ = invk_nd(x2,x1,list_nd(x2,x3)) +#define Pdcolist0(x) $$ = tree3(N_Create,x,x);\ + proc_lst->has_coexpr = 1; +#define Pdcolist1(x1,x2,x3) $$ =tree4(N_Elist,x2,x1,tree3(N_Create,x2,x3));\ + proc_lst->has_coexpr = 1; +#define Proc1(x1,x2,x3,x4,x5,x6) $$ = tree6(N_Proc,x1,x1,x4,x5,x6) +#define Procbody1() $$ = EmptyNode +#define Procbody2(x1,x2,x3) $$ = tree4(N_Slist,x2,x1,x3) +#define Procdcl(x) proc_lst->tree = x +#define Prochead1(x1,x2) init_proc(Str0(x2));\ + idflag = F_Argument +#define Prochead2(x1,x2,x3,x4,x5,x6) /* empty */ +#define Progend(x1,x2) /* empty */ +#define Recdcl(x) /* empty */ +#define Record1(x1, x2) init_rec(Str0(x2));\ + idflag = F_Field +#define Record2(x1,x2,x3,x4,x5,x6) /* empty */ +#define Repeat(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) +#define Return(x1,x2) $$ = tree4(N_Ret,x1,x1,x2) +#define Rliter(x) CSym0(x) = putlit(Str0(x),F_RealLit,0) +#define Section(x1,x2,x3,x4,x5,x6) $$ = sect_nd(x4,x1,x3,x5) +#define Sliter(x) CSym0(x) = putlit(Str0(x),F_StrLit,(int)Val1(x)) +#define Static(x) idflag = F_Static +#define Subscript(x1,x2,x3,x4) $$ = buildarray(x1,x2,x3) +#define Suspend0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) +#define Suspend1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) +#define To0(x1,x2,x3) $$ = to_nd(x2,x1,x3) +#define To1(x1,x2,x3,x4,x5) $$ = toby_nd(x2,x1,x3,x5) +#define Uat(x1,x2) $$ = tree5(N_Activat,x1,x1,EmptyNode,x2) +#define Ubackslash(x1,x2) $$ = unary_nd(x1,x2) +#define Ubang(x1,x2) $$ = unary_nd(x1,x2) +#define Ubar(x1,x2) $$ = tree3(N_Bar,x2,x2) +#define Ucaret(x1,x2) $$ = unary_nd(x1,x2) +#define Uconcat(x1,x2) $$ = tree3(N_Bar,x2,x2) +#define Udiff(x1,x2) $$ = MultiUnary(x1,x2) +#define Udot(x1,x2) $$ = unary_nd(x1,x2) +#define Uequiv(x1,x2) $$ = MultiUnary(x1,x2) +#define Uinter(x1,x2) $$ = MultiUnary(x1,x2) +#define Ulconcat(x1,x2) $$ = tree3(N_Bar,x2,x2) +#define Ulexeq(x1,x2) $$ = MultiUnary(x1,x2) +#define Ulexne(x1,x2) $$ = MultiUnary(x1,x2) +#define Uminus(x1,x2) $$ = unary_nd(x1,x2) +#define Unot(x1,x2) $$ = tree3(N_Not,x2,x2) +#define Unotequiv(x1,x2) $$ = MultiUnary(x1,x2) +#define Until0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) +#define Until1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) +#define Unumeq(x1,x2) $$ = unary_nd(x1,x2) +#define Unumne(x1,x2) $$ = MultiUnary(x1,x2) +#define Uplus(x1,x2) $$ = unary_nd(x1,x2) +#define Uqmark(x1,x2) $$ = unary_nd(x1,x2) +#define Uslash(x1,x2) $$ = unary_nd(x1,x2) +#define Ustar(x1,x2) $$ = unary_nd(x1,x2) +#define Utilde(x1,x2) $$ = unary_nd(x1,x2) +#define Uunion(x1,x2) $$ = MultiUnary(x1,x2) +#define Var(x) LSym0(x) = putloc(Str0(x),0) +#define While0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) +#define While1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) +%} + +%% +#include "../h/grammar.h" +%% + +/* + * xfree(p) -- used with free(p) macro to avoid compiler errors from + * miscast free calls generated by Yacc. + */ +#undef free +static void xfree(p) +char *p; +{ + free(p); +} + +/*#define free(p) xfree((char*)p)*/ diff --git a/src/iconc/chkinv.c b/src/iconc/chkinv.c new file mode 100644 index 0000000..af4298f --- /dev/null +++ b/src/iconc/chkinv.c @@ -0,0 +1,545 @@ +/* + * chkinv.c - routines to determine which global names are only + * used as immediate operand to invocation and to directly invoke + * the corresponding operations. In addition, simple assignments to + * names variables are recognized and it is determined whether + * procedures return, suspend, or fail. + */ +#include "../h/gsupport.h" +#include "ctrans.h" +#include "csym.h" +#include "ctree.h" +#include "ctoken.h" +#include "cglobals.h" +#include "ccode.h" +#include "cproto.h" + +/* + * prototypes for static functions. + */ +static int chg_ret (int flag); +static void chksmpl (struct node *n, int smpl_invk); +static int seq_exec (int exec_flg1, int exec_flg2); +static int spcl_inv (struct node *n, struct node *asgn); + +static ret_flag; + +/* + * chkinv - check for invocation and assignment optimizations. + */ +void chkinv() + { + struct gentry *gp; + struct pentry *proc; + int exec_flg; + int i; + + if (debug_info) + return; /* The following analysis is not valid */ + + /* + * start off assuming that global variables for procedure, etc. are + * only used as immediate operands to invocations then mark any + * which are not. Any variables retaining the property are never + * changed. Go through the code and change invocations to such + * variables to invocations directly to the operation. + */ + for (i = 0; i < GHSize; i++) + for (gp = ghash[i]; gp != NULL; gp = gp->blink) { + if (gp->flag & (F_Proc | F_Builtin | F_Record) && + !(gp->flag & F_StrInv)) + gp->flag |= F_SmplInv; + /* + * However, only optimize normal cases for main. + */ + if (strcmp(gp->name, "main") == 0 && (gp->flag & F_Proc) && + (gp->val.proc->nargs < 0 || gp->val.proc->nargs > 1)) + gp->flag &= ~(uword)F_SmplInv; + /* + * Work-around to problem that a co-expression block needs + * block for enclosing procedure: just keep procedure in + * a variable to force outputting the block. Note, this + * inhibits tailored calling conventions for the procedure. + */ + if ((gp->flag & F_Proc) && gp->val.proc->has_coexpr) + gp->flag &= ~(uword)F_SmplInv; + } + + /* + * Analyze code in each procedure. + */ + for (proc = proc_lst; proc != NULL; proc = proc->next) { + chksmpl(Tree1(proc->tree), 0); /* initial expression */ + chksmpl(Tree2(proc->tree), 0); /* procedure body */ + } + + /* + * Go through each procedure performing "naive" optimizations on + * invocations and assignments. Also determine whether the procedure + * returns, suspends, or fails (possibly by falling through to + * the end). + */ + for (proc = proc_lst; proc != NULL; proc = proc->next) { + ret_flag = 0; + spcl_inv(Tree1(proc->tree), NULL); + exec_flg = spcl_inv(Tree2(proc->tree), NULL); + if (exec_flg & DoesFThru) + ret_flag |= DoesFail; + proc->ret_flag = ret_flag; + } + } + +/* + * smpl_invk - find any global variable uses that are not a simple + * invocation and mark the variables. + */ +static void chksmpl(n, smpl_invk) +struct node *n; +int smpl_invk; + { + struct node *cases; + struct node *clause; + struct lentry *var; + int i; + int lst_arg; + + switch (n->n_type) { + case N_Alt: + case N_Apply: + case N_Limit: + case N_Slist: + chksmpl(Tree0(n), 0); + chksmpl(Tree1(n), 0); + break; + + case N_Activat: + chksmpl(Tree1(n), 0); + chksmpl(Tree2(n), 0); + break; + + case N_Augop: + chksmpl(Tree2(n), 0); + chksmpl(Tree3(n), 0); + break; + + case N_Bar: + case N_Break: + case N_Create: + case N_Field: + case N_Not: + chksmpl(Tree0(n), 0); + break; + + case N_Case: + chksmpl(Tree0(n), 0); /* control clause */ + cases = Tree1(n); + while (cases != NULL) { + if (cases->n_type == N_Ccls) { + clause = cases; + cases = NULL; + } + else { + clause = Tree1(cases); + cases = Tree0(cases); + } + + chksmpl(Tree0(clause), 0); /* value of clause */ + chksmpl(Tree1(clause), 0); /* body of clause */ + } + if (Tree2(n) != NULL) + chksmpl(Tree2(n), 0); /* default */ + break; + + case N_Cset: + case N_Int: + case N_Real: + case N_Str: + case N_Empty: + case N_Next: + break; + + case N_Id: + if (!smpl_invk) { + /* + * The variable is being used somewhere other than in a simple + * invocation. + */ + var = LSym0(n); + if (var->flag & F_Global) + var->val.global->flag &= ~F_SmplInv; + } + break; + + case N_If: + chksmpl(Tree0(n), 0); + chksmpl(Tree1(n), 0); + chksmpl(Tree2(n), 0); + break; + + case N_Invok: + lst_arg = 1 + Val0(n); + /* + * Check the thing being invoked, noting that it is in fact being + * invoked. + */ + chksmpl(Tree1(n), 1); + for (i = 2; i <= lst_arg; ++i) + chksmpl(n->n_field[i].n_ptr, 0); /* arg i - 1 */ + break; + + case N_InvOp: + lst_arg = 1 + Val0(n); + for (i = 2; i <= lst_arg; ++i) + chksmpl(n->n_field[i].n_ptr, 0); /* arg i */ + break; + + case N_Loop: { + switch ((int)Val0(Tree0(n))) { + case EVERY: + case SUSPEND: + case WHILE: + case UNTIL: + chksmpl(Tree1(n), 0); /* control clause */ + chksmpl(Tree2(n), 0); /* do clause */ + break; + + case REPEAT: + chksmpl(Tree1(n), 0); /* clause */ + break; + } + } + + case N_Ret: + if (Val0(Tree0(n)) == RETURN) + chksmpl(Tree1(n), 0); + break; + + case N_Scan: + chksmpl(Tree1(n), 0); + chksmpl(Tree2(n), 0); + break; + + case N_Sect: + chksmpl(Tree2(n), 0); + chksmpl(Tree3(n), 0); + chksmpl(Tree4(n), 0); + break; + + default: + fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); + exit(EXIT_FAILURE); + } + } + +/* + * spcl_inv - look for general invocations that can be replaced by + * special invocations. Simple assignment to a named variable is + * is a particularly special case. Also, determine whether execution + * might "fall through" this code and whether the code might fail. + */ +static int spcl_inv(n, asgn) +struct node *n; +struct node *asgn; /* the result goes into this special-cased assignment */ + { + struct node *cases; + struct node *clause; + struct node *invokee; + struct gentry *gvar; + struct loop { + int exec_flg; + struct node *asgn; + struct loop *prev; + } loop_info; + struct loop *loop_sav; + int exec_flg; + int i; + int lst_arg; + static struct loop *cur_loop = NULL; + + switch (n->n_type) { + case N_Activat: + if (asgn != NULL) + Val0(asgn) = AsgnDeref; /* assume worst case */ + return seq_exec(spcl_inv(Tree1(n), NULL), spcl_inv(Tree2(n), NULL)); + + case N_Alt: + exec_flg = spcl_inv(Tree0(n), asgn) & DoesFThru; + return exec_flg | spcl_inv(Tree1(n), asgn); + + case N_Apply: + if (asgn != NULL) + Val0(asgn) = AsgnCopy; /* assume worst case */ + return seq_exec(spcl_inv(Tree0(n), NULL), spcl_inv(Tree1(n), NULL)); + + case N_Augop: + exec_flg = chg_ret(Impl1(n)->ret_flag); + if (Tree2(n)->n_type == N_Id) { + /* + * This is an augmented assignment to a named variable. + * An optimized version of assignment can be used. + */ + n->n_type = N_SmplAug; + if (Impl1(n)->use_rslt) + Val0(n) = AsgnCopy; + else + Val0(n) = AsgnDirect; + } + else { + if (asgn != NULL) + Val0(asgn) = AsgnDeref; /* this operation produces a variable */ + exec_flg = seq_exec(exec_flg, spcl_inv(Tree2(n), NULL)); + exec_flg = seq_exec(exec_flg, chg_ret(Impl0(n)->ret_flag)); + } + return seq_exec(exec_flg, spcl_inv(Tree3(n), NULL)); + + case N_Bar: + return spcl_inv(Tree0(n), asgn); + + case N_Break: + if (cur_loop == NULL) { + nfatal(n, "invalid context for break", NULL); + return 0; + } + loop_sav = cur_loop; + cur_loop = cur_loop->prev; + loop_sav->exec_flg |= spcl_inv(Tree0(n), loop_sav->asgn); + cur_loop = loop_sav; + return 0; + + case N_Create: + spcl_inv(Tree0(n), NULL); + return DoesFThru; + + case N_Case: + exec_flg = spcl_inv(Tree0(n), NULL) & DoesFail; /* control clause */ + cases = Tree1(n); + while (cases != NULL) { + if (cases->n_type == N_Ccls) { + clause = cases; + cases = NULL; + } + else { + clause = Tree1(cases); + cases = Tree0(cases); + } + + spcl_inv(Tree0(clause), NULL); + exec_flg |= spcl_inv(Tree1(clause), asgn); + } + if (Tree2(n) != NULL) + exec_flg |= spcl_inv(Tree2(n), asgn); /* default */ + else + exec_flg |= DoesFail; + return exec_flg; + + case N_Cset: + case N_Int: + case N_Real: + case N_Str: + case N_Empty: + return DoesFThru; + + case N_Field: + if (asgn != NULL) + Val0(asgn) = AsgnDeref; /* operation produces variable */ + return spcl_inv(Tree0(n), NULL); + + case N_Id: + if (asgn != NULL) + Val0(asgn) = AsgnDeref; /* variable */ + return DoesFThru; + + case N_If: + spcl_inv(Tree0(n), NULL); + exec_flg = spcl_inv(Tree1(n), asgn); + if (Tree2(n)->n_type == N_Empty) + exec_flg |= DoesFail; + else + exec_flg |= spcl_inv(Tree2(n), asgn); + return exec_flg; + + case N_Invok: + lst_arg = 1 + Val0(n); + invokee = Tree1(n); + exec_flg = DoesFThru; + for (i = 2; i <= lst_arg; ++i) + exec_flg = seq_exec(exec_flg, spcl_inv(n->n_field[i].n_ptr, NULL)); + if (invokee->n_type == N_Id && LSym0(invokee)->flag & F_Global) { + /* + * This is an invocation of a global variable. If we can + * convert this to a direct invocation, determine whether + * it is an invocation of a procedure, built-in function, + * or record constructor; each has a difference kind of + * direct invocation node. + */ + gvar = LSym0(invokee)->val.global; + if (gvar->flag & F_SmplInv) { + switch (gvar->flag & (F_Proc | F_Builtin | F_Record)) { + case F_Proc: + n->n_type = N_InvProc; + Proc1(n) = gvar->val.proc; + return DoesFThru | DoesFail; /* assume worst case */ + case F_Builtin: + n->n_type = N_InvOp; + Impl1(n) = gvar->val.builtin; + if (asgn != NULL && Impl1(n)->use_rslt) + Val0(asgn) = AsgnCopy; + return seq_exec(exec_flg, chg_ret( + gvar->val.builtin->ret_flag)); + case F_Record: + n->n_type = N_InvRec; + Rec1(n) = gvar->val.rec; + return seq_exec(exec_flg, DoesFThru | + (err_conv ? DoesFail : 0)); + } + } + } + if (asgn != NULL) + Val0(asgn) = AsgnCopy; /* assume worst case */ + spcl_inv(invokee, NULL); + return DoesFThru | DoesFail; /* assume worst case */ + + case N_InvOp: + if (Impl1(n)->op != NULL && strcmp(Impl1(n)->op, ":=") == 0 && + Tree2(n)->n_type == N_Id) { + /* + * This is a simple assignment to a named variable. + * An optimized version of assignment can be used. + */ + n->n_type = N_SmplAsgn; + + /* + * For now, assume rhs of := can compute directly into a + * variable. This may be changed when the rhs is examined + * in the recursive call to spcl_inv(). + */ + Val0(n) = AsgnDirect; + return spcl_inv(Tree3(n), n); + } + else { + /* + * No special cases. + */ + lst_arg = 1 + Val0(n); + exec_flg = chg_ret(Impl1(n)->ret_flag); + for (i = 2; i <= lst_arg; ++i) + exec_flg = seq_exec(exec_flg, spcl_inv(n->n_field[i].n_ptr, + NULL)); /* arg i */ + if (asgn != NULL && Impl1(n)->use_rslt) + Val0(asgn) = AsgnCopy; + return exec_flg; + } + + case N_Limit: + return seq_exec(spcl_inv(Tree0(n), asgn), + spcl_inv(Tree1(n), NULL)) | DoesFail; + + case N_Loop: { + loop_info.prev = cur_loop; + loop_info.exec_flg = 0; + loop_info.asgn = asgn; + cur_loop = &loop_info; + switch ((int)Val0(Tree0(n))) { + case EVERY: + case WHILE: + case UNTIL: + spcl_inv(Tree1(n), NULL); /* control clause */ + spcl_inv(Tree2(n), NULL); /* do clause */ + exec_flg = DoesFail; + break; + + case SUSPEND: + spcl_inv(Tree1(n), NULL); /* control clause */ + spcl_inv(Tree2(n), NULL); /* do clause */ + ret_flag |= DoesSusp; + exec_flg = DoesFail; + break; + + case REPEAT: + spcl_inv(Tree1(n), NULL); /* clause */ + exec_flg = 0; + break; + } + exec_flg |= cur_loop->exec_flg; + cur_loop = cur_loop->prev; + return exec_flg; + } + + case N_Next: + return 0; + + case N_Not: + exec_flg = spcl_inv(Tree0(n), NULL); + return ((exec_flg & DoesFail) ? DoesFThru : 0) | + ((exec_flg & DoesFThru) ? DoesFail: 0); + + case N_Ret: + if (Val0(Tree0(n)) == RETURN) { + exec_flg = spcl_inv(Tree1(n), NULL); + ret_flag |= DoesRet; + if (exec_flg & DoesFail) + ret_flag |= DoesFail; + } + else + ret_flag |= DoesFail; + return 0; + + case N_Scan: + if (asgn != NULL) + Val0(asgn) = AsgnCopy; /* assume worst case */ + return seq_exec(spcl_inv(Tree1(n), NULL), + spcl_inv(Tree2(n), NULL)); + + case N_Sect: + if (asgn != NULL && Impl0(n)->use_rslt) + Val0(asgn) = AsgnCopy; + exec_flg = spcl_inv(Tree2(n), NULL); + exec_flg = seq_exec(exec_flg, spcl_inv(Tree3(n), NULL)); + exec_flg = seq_exec(exec_flg, spcl_inv(Tree4(n), NULL)); + return seq_exec(exec_flg, chg_ret(Impl0(n)->ret_flag)); + + case N_Slist: + exec_flg = spcl_inv(Tree0(n), NULL); + if (exec_flg & (DoesFThru | DoesFail)) + exec_flg = DoesFThru; + return seq_exec(exec_flg, spcl_inv(Tree1(n), asgn)); + + default: + fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); + exit(EXIT_FAILURE); + /* NOTREACHED */ + } + } + +/* + * seq_exec - take the execution flags for sequential pieces of code + * and compute the flags for the combined code. + */ +static int seq_exec(exec_flg1, exec_flg2) +int exec_flg1; +int exec_flg2; + { + return (exec_flg1 & exec_flg2 & DoesFThru) | + ((exec_flg1 | exec_flg2) & DoesFail); + } + +/* + * chg_ret - take a return flag and change suspend and return to + * "fall through". If error conversion is supported, change error + * failure to failure. + * + */ +static int chg_ret(flag) +int flag; + { + int flg1; + + flg1 = flag & DoesFail; + if (flag & (DoesRet | DoesSusp)) + flg1 |= DoesFThru; + if (err_conv && (flag & DoesEFail)) + flg1 |= DoesFail; + return flg1; + } + + diff --git a/src/iconc/clex.c b/src/iconc/clex.c new file mode 100644 index 0000000..8e7d657 --- /dev/null +++ b/src/iconc/clex.c @@ -0,0 +1,18 @@ +/* + * clex.c -- the lexical analyzer for iconc. + */ +#define Iconc + +#include "../h/gsupport.h" +#include "../h/lexdef.h" +#include "ctrans.h" +#include "ctoken.h" +#include "ctree.h" +#include "csym.h" +#include "ccode.h" +#include "cproto.h" + +#include "../h/parserr.h" +#include "../common/lextab.h" +#include "../common/yylex.h" +#include "../common/error.h" diff --git a/src/iconc/cmain.c b/src/iconc/cmain.c new file mode 100644 index 0000000..6daf5c4 --- /dev/null +++ b/src/iconc/cmain.c @@ -0,0 +1,424 @@ +/* + * cmain.c - main program icon compiler. + */ +#include "../h/gsupport.h" +#include "ctrans.h" +#include "ctree.h" +#include "ccode.h" +#include "csym.h" +#include "cproto.h" + +/* + * Prototypes. + */ +static void execute (char *ofile, char **args); +static FILE *open_out (char *fname); +static void rmfile (char *fname); +static void report (char *s); +static void usage (void); + +char *refpath; + +char patchpath[MaxPath+18] = "%PatchStringHere->"; + +/* + * Define global variables. + */ + +#define Global +#define Init(v) = v +#include "cglobals.h" + +/* + * getopt() variables + */ +extern int optind; /* index into parent argv vector */ +extern int optopt; /* character checked for validity */ +extern char *optarg; /* argument associated with option */ + +/* + * main program + */ +int main(argc,argv) +int argc; +char **argv; + { + int no_c_comp = 0; /* suppress C compile and link? */ + int errors = 0; /* compilation errors */ + char *cfile = NULL; /* name of C file - primary */ + char *hfile = NULL; /* name of C file - include */ + char *ofile = NULL; /* name of executable result */ + + char *db_name = "rt.db"; /* data base name */ + char *incl_file = "rt.h"; /* header file name */ + + char *db_path; /* path to data base */ + char *db_lst; /* list of private data bases */ + char *incl_path; /* path to header file */ + char *s, c1; + char buf[MaxPath]; /* file name construction buffer */ + int c; + int ret_code; + struct fileparts *fp; + + if ((int)strlen(patchpath) > 18) + refpath = patchpath+18; + else + refpath = relfile(argv[0], "/../"); + + /* + * Process options. + */ + while ((c = getopt(argc,argv,"+C:ELS:Tcf:mn:o:p:r:stuv:x")) != EOF) + switch (c) { + case 'C': /* -C C-comp: C compiler*/ + c_comp = optarg; + break; + case 'E': /* -E: preprocess only */ + pponly = 1; + no_c_comp = 1; + break; + case 'L': /* Ignore: interpreter only */ + break; + case 'S': /* Ignore: interpreter only */ + break; + case 'T': + just_type_trace = 1; + break; + case 'c': /* -c: produce C file only */ + no_c_comp = 1; + break; + case 'f': /* -f: enable features */ + for (s = optarg; *s != '\0'; ++s) { + switch (*s) { + case 'a': /* -fa: enable all features */ + line_info = 1; + debug_info = 1; + err_conv = 1; + largeints = 1; + str_inv = 1; + break; + case 'd': /* -fd: enable debugging features */ + line_info = 1; + debug_info = 1; + break; + case 'e': /* -fe: enable error conversion */ + err_conv = 1; + break; + case 'l': /* -fl: support large integers */ + largeints = 1; + break; + case 'n': /* -fn: enable line numbers */ + line_info = 1; + break; + case 's': /* -fs: enable full string invocation */ + str_inv = 1; + break; + default: + quitf("-f option must be a, d, e, l, n, or s. found: %s", + optarg); + } + } + break; + case 'm': /* -m: preprocess using m4(1) */ + m4pre = 1; + break; + case 'n': /* -n: disable optimizations */ + for (s = optarg; *s != '\0'; ++s) { + switch (*s) { + case 'a': /* -na: disable all optimizations */ + opt_cntrl = 0; + allow_inline = 0; + opt_sgnl = 0; + do_typinfer = 0; + break; + case 'c': /* -nc: disable control flow opts */ + opt_cntrl = 0; + break; + case 'e': /* -ne: disable expanding in-line */ + allow_inline = 0; + break; + case 's': /* -ns: disable switch optimizations */ + opt_sgnl = 0; + break; + case 't': /* -nt: disable type inference */ + do_typinfer = 0; + break; + default: + usage(); + } + } + break; + case 'o': /* -o file: name output file */ + ofile = optarg; + break; + case 'p': /* -p C-opts: options for C comp */ + if (*optarg == '\0') /* if empty string, clear options */ + c_opts = optarg; + else { /* else append to current set */ + s = (char *)alloc(strlen(c_opts) + 1 + strlen(optarg) + 1); + sprintf(s, "%s %s", c_opts, optarg); + c_opts = s; + } + break; + case 'r': /* -r path: primary runtime system */ + refpath = optarg; + break; + case 's': /* -s: suppress informative messages */ + verbose = 0; + break; + case 't': /* -t: &trace = -1 */ + line_info = 1; + debug_info = 1; + trace = 1; + break; + case 'u': /* -u: warn about undeclared ids */ + uwarn = 1; + break; + case 'v': /* -v: set level of verbosity */ + if (sscanf(optarg, "%d%c", &verbose, &c1) != 1) + quitf("bad operand to -v option: %s",optarg); + break; + default: + case 'x': /* -x illegal until after file list */ + usage(); + } + + init(); /* initialize memory for translation */ + + /* + * Load the data bases of information about run-time routines and + * determine what libraries are needed for linking (these libraries + * go before any specified on the command line). + */ + db_lst = getenv("DBLIST"); + if (db_lst != NULL) + db_lst = salloc(db_lst); + s = db_lst; + while (s != NULL) { + db_lst = s; + while (isspace(*db_lst)) + ++db_lst; + if (*db_lst == '\0') + break; + for (s = db_lst; !isspace(*s) && *s != '\0'; ++s) + ; + if (*s == '\0') + s = NULL; + else + *s++ = '\0'; + readdb(db_lst); + addlib(salloc(makename(buf,SourceDir, db_lst, LibSuffix))); + } + db_path = (char *)alloc((unsigned int)strlen(refpath) + strlen(db_name) + 1); + strcpy(db_path, refpath); + strcat(db_path, db_name); + readdb(db_path); + addlib(salloc(makename(buf,SourceDir, db_path, LibSuffix))); + + /* + * Scan the rest of the command line for file name arguments. + */ + while (optind < argc) { + if (strcmp(argv[optind],"-x") == 0) /* stop at -x */ + break; + else if (strcmp(argv[optind],"-") == 0) + src_file("-"); /* "-" means standard input */ + else if (argv[optind][0] == '-') + addlib(argv[optind]); /* assume linker option */ + else { + fp = fparse(argv[optind]); /* parse file name */ + if (*fp->ext == '\0' || smatch(fp->ext, SourceSuffix)) { + makename(buf,SourceDir,argv[optind], SourceSuffix); + src_file(buf); + } + else + /* + * Assume all files that are not Icon source go to linker. + */ + addlib(argv[optind]); + } + optind++; + } + + if (srclst == NULL) + usage(); /* error -- no files named */ + + if (pponly) { + if (trans() == 0) + exit (EXIT_FAILURE); + else + exit (EXIT_SUCCESS); + } + + if (ofile == NULL) { /* if no -o file, synthesize a name */ + if (strcmp(srclst->name,"-") == 0) + ofile = salloc(makename(buf,TargetDir,"stdin",ExecSuffix)); + else + ofile = salloc(makename(buf,TargetDir,srclst->name,ExecSuffix)); + } else { /* add extension if necessary */ + fp = fparse(ofile); + if (*fp->ext == '\0' && *ExecSuffix != '\0') + ofile = salloc(makename(buf,NULL,ofile,ExecSuffix)); + } + + /* + * Make name of intermediate C files. + */ + cfile = salloc(makename(buf,TargetDir,ofile,CSuffix)); + hfile = salloc(makename(buf,TargetDir,ofile,HSuffix)); + + codefile = open_out(cfile); + fprintf(codefile, "#include \"%s\"\n", hfile); + + inclfile = open_out(hfile); + fprintf(inclfile, "#define COMPILER 1\n"); + + incl_path = (char *)alloc((unsigned int)(strlen(refpath) + + strlen(incl_file) + 1)); + strcpy(incl_path, refpath); + strcat(incl_path, incl_file); + fprintf(inclfile,"#include \"%s\"\n", incl_path); + + /* + * Translate .icn files to make C file. + */ + if ((verbose > 0) && !just_type_trace) + report("Translating to C"); + + errors = trans(); + if ((errors > 0) || just_type_trace) { /* exit if errors seen */ + rmfile(cfile); + rmfile(hfile); + if (errors > 0) + exit(EXIT_FAILURE); + else exit(EXIT_SUCCESS); + } + + fclose(codefile); + fclose(inclfile); + + /* + * Compile and link C file. + */ + if (no_c_comp) /* exit if no C compile wanted */ + exit(EXIT_SUCCESS); + + if (verbose > 0) + report("Compiling and linking C code"); + + ret_code = ccomp(cfile, ofile); + if (ret_code == EXIT_FAILURE) { + fprintf(stderr, "*** C compile and link failed ***\n"); + rmfile(ofile); + } + + /* + * Finish by removing C files. + */ + rmfile(cfile); + rmfile(hfile); + rmfile(makename(buf,TargetDir,cfile,ObjSuffix)); + + if (ret_code == EXIT_SUCCESS && optind < argc) { + if (verbose > 0) + report("Executing"); + execute (ofile, argv+optind+1); + } + + return ret_code; + } + +/* + * execute - execute compiled Icon program + */ +static void execute(ofile,args) +char *ofile, **args; + { + + int n; + char **argv, **p; + char buf[MaxPath]; /* file name construction buffer */ + + ofile = salloc(makename(buf,"./",ofile,ExecSuffix)); + + for (n = 0; args[n] != NULL; n++) /* count arguments */ + ; + p = argv = (char **)alloc((unsigned int)((n + 2) * sizeof(char *))); + + *p++ = ofile; /* set executable file */ + + while (*p++ = *args++) /* copy args into argument vector */ + ; + *p = NULL; + + execvp(ofile,argv); + quitf("could not run %s",ofile); + } + +/* + * Report phase. + */ +static void report(s) +char *s; + { + fprintf(stderr,"%s:\n",s); + } + +/* + * rmfile - remove a file + */ + +static void rmfile(fname) +char *fname; + { + remove(fname); + } + +/* + * open_out - open a C output file and write identifying information + * to the front. + */ +static FILE *open_out(fname) +char *fname; + { + FILE *f; + static char *ident = "/*ICONC*/"; + int c; + int i; + + /* + * If the file already exists, make sure it is old output from iconc + * before overwriting it. Note, this test doesn't work if the file + * is writable but not readable. + */ + f = fopen(fname, "r"); + if (f != NULL) { + for (i = 0; i < (int)strlen(ident); ++i) { + c = getc(f); + if (c == EOF) + break; + if ((char)c != ident[i]) + quitf("%s not in iconc format; rename or delete, and rerun", fname); + } + fclose(f); + } + + f = fopen(fname, "w"); + if (f == NULL) + quitf("cannot create %s", fname); + fprintf(f, "%s\n", ident); /* write "belongs to iconc" comment */ + id_comment(f); /* write detailed comment for human readers */ + fflush(f); + return f; + } + +/* + * Print an error message if called incorrectly. The message depends + * on the legal options for this system. + */ +static void usage() + { + fprintf(stderr,"usage: %s %s file ... [-x args]\n", progname, CUsage); + exit(EXIT_FAILURE); + } diff --git a/src/iconc/cmem.c b/src/iconc/cmem.c new file mode 100644 index 0000000..720a495 --- /dev/null +++ b/src/iconc/cmem.c @@ -0,0 +1,114 @@ +/* + * cmem.c -- memory initialization and allocation for the translator. + */ +#include "../h/gsupport.h" +#include "cglobals.h" +#include "ctrans.h" +#include "csym.h" +#include "ctree.h" +#include "ccode.h" +#include "cproto.h" + +struct centry *chash[CHSize]; /* hash area for constant table */ +struct fentry *fhash[FHSize]; /* hash area for field table */ +struct gentry *ghash[GHSize]; /* hash area for global table */ + +struct implement *bhash[IHSize]; /* hash area for built-in functions */ +struct implement *khash[IHSize]; /* hash area for keywords */ +struct implement *ohash[IHSize]; /* hash area for operators */ + +struct implement *spec_op[NumSpecOp]; /* table of ops with special syntax */ + +char pre[PrfxSz] = {'0', '0', '0'}; /* initial function name prefix */ + +extern struct str_buf lex_sbuf; + + +/* + * init - initialize memory for the translator + */ + +void init() +{ + int i; + + init_str(); + init_sbuf(&lex_sbuf); + + /* + * Zero out the hash tables. + */ + for (i = 0; i < CHSize; i++) + chash[i] = NULL; + for (i = 0; i < FHSize; i++) + fhash[i] = NULL; + for (i = 0; i < GHSize; i++) + ghash[i] = NULL; + for (i = 0; i < IHSize; i++) { + bhash[i] = NULL; + khash[i] = NULL; + ohash[i] = NULL; + } + + /* + * Clear table of operators with non-standard operator syntax. + */ + for (i = 0; i < NumSpecOp; ++i) + spec_op[i] = NULL; + } + +/* + * init_proc - add a new entry on front of procedure list. + */ +void init_proc(name) +char *name; + { + register struct pentry *p; + int i; + struct gentry *sym_ent; + + p = NewStruct(pentry); + p->name = name; + nxt_pre(p->prefix, pre, PrfxSz); + p->prefix[PrfxSz] = '\0'; + p->nargs = 0; + p->args = NULL; + p->ndynam = 0; + p->dynams = NULL; + p->nstatic = 0; + p->has_coexpr = 0; + p->statics = NULL; + p->ret_flag = DoesRet | DoesFail | DoesSusp; /* start out pessimistic */ + p->arg_lst = 0; + p->lhash = + (struct lentry **)alloc((unsigned int)((LHSize)*sizeof(struct lentry *))); + for (i = 0; i < LHSize; i++) + p->lhash[i] = NULL; + p->next = proc_lst; + proc_lst = p; + sym_ent = instl_p(name, F_Proc); + sym_ent->val.proc = proc_lst; + } + +/* + * init_rec - add a new entry on the front of the record list. + */ +void init_rec(name) +char *name; + { + register struct rentry *r; + struct gentry *sym_ent; + static int rec_num = 0; + + r = NewStruct(rentry); + r->name = name; + nxt_pre(r->prefix, pre, PrfxSz); + r->prefix[PrfxSz] = '\0'; + r->rec_num = rec_num++; + r->nfields = 0; + r->fields = NULL; + r->next = rec_lst; + rec_lst = r; + sym_ent= instl_p(name, F_Record); + sym_ent->val.rec = r; + } diff --git a/src/iconc/codegen.c b/src/iconc/codegen.c new file mode 100644 index 0000000..8ca5bd1 --- /dev/null +++ b/src/iconc/codegen.c @@ -0,0 +1,1918 @@ +/* + * codegen.c - routines to write out C code. + */ +#include "../h/gsupport.h" +#include "ctrans.h" +#include "cglobals.h" +#include "csym.h" +#include "ccode.h" +#include "ctree.h" +#include "cproto.h" + +#ifndef LoopThreshold +#define LoopThreshold 7 +#endif /* LoopThreshold */ + +/* + * MinOne - arrays sizes must be at least 1. + */ +#define MinOne(n) ((n) > 0 ? (n) : 1) + +/* + * ChkSeqNum - make sure a label has been given a sequence number. + */ +#define ChkSeqNum(x) if ((x)->SeqNum == 0) (x)->SeqNum = ++lbl_seq_num + +/* + * ChkBound - for a given procedure, signals that transfer control to a + * bounding label all use the same signal number. + */ +#define ChkBound(x) (((x)->LabFlg & Bounding) ? bound_sig : (x)) + +/* + * When a switch statement for signal handling is optimized, there + * are three possible forms of default clauses. + */ +#define DfltNone 0 /* no default clause */ +#define DfltBrk 1 /* default is just a break */ +#define DfltRetSig 2 /* default is to return the signal from the call */ + +/* + * Prototypes for static functions. + */ +static int arg_nms (struct lentry *lptr, int prt); +static void bi_proc (char *name, struct implement *ip); +static void chkforgn (int outer); +static int dyn_nms (struct lentry *lptr, int prt); +static void fldnames (struct fldname *fields); +static void fnc_blk (struct gentry *gptr); +static void frame (int outer); +static void good_clsg (struct code *call, int outer); +static void initpblk (FILE *f, int c, char *prefix, char *name, + int nquals, int nparam, int ndynam, int nstatic, + int frststat); +static char *is_builtin (struct gentry *gptr); +static void proc_blk (struct gentry *gptr, int init_glbl); +static void prt_ary (struct code *cd, int outer); +static void prt_cond (struct code *cond); +static void prt_cont (struct c_fnc *cont); +static void prt_var (struct lentry *var, int outer); +static void prtcall (struct code *call, int outer); +static void prtcode (struct code *cd, int outer); +static void prtpccall (int outer); +static void rec_blk (struct gentry *gptr, int init_glbl); +static void smpl_clsg (struct code *call, int outer); +static void stat_nms (struct lentry *lptr, int prt); +static void val_loc (struct val_loc *rslt, int outer); + +static int n_stat = -1; /* number of static variables */ + +/* + * var_dcls - produce declarations necessary to implement variables + * and to initialize globals and statics: procedure blocks, procedure + * frames, record blocks, declarations for globals and statics, the + * C main program. + */ +void var_dcls() + { + register int i; + register struct gentry *gptr; + struct gentry *gbl_main; + struct pentry *prc_main; + int n_glob = 0; + int flag; + int init_glbl; + int first; + char *pfx; + + /* + * Output initialized array of descriptors for globals. + */ + fprintf(codefile, "\nstatic struct {word dword; union block *vword;}"); + fprintf(codefile, " init_globals[NGlobals] = {\n"); + prc_main = NULL; + for (i = 0; i < GHSize; i++) + for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { + flag = gptr->flag & ~(F_Global | F_StrInv); + if (strcmp(gptr->name, "main") == 0 && (gptr->flag & F_Proc)) { + /* + * Remember main procedure. + */ + gbl_main = gptr; + prc_main = gbl_main->val.proc; + } + if (flag == 0) { + /* + * Ordinary variable. + */ + gptr->index = n_glob++; + fprintf(codefile, " {D_Null},\n"); + } + else { + /* + * Procedure, function, or record constructor. If the variable + * has not been optimized away, initialize the it to reference + * the procedure block. + */ + if (flag & F_SmplInv) { + init_glbl = 0; + flag &= ~(uword)F_SmplInv; + } + else { + init_glbl = 1; + gptr->index = n_glob++; + fprintf(codefile, " {D_Proc, "); + } + switch (flag) { + case F_Proc: + proc_blk(gptr, init_glbl); + break; + case F_Builtin: + if (init_glbl) + fnc_blk(gptr); + break; + case F_Record: + rec_blk(gptr, init_glbl); + } + } + } + if (n_glob == 0) + fprintf(codefile, " {D_Null} /* place holder */\n"); + fprintf(codefile, " };\n"); + + if (prc_main == NULL) { + nfatal(NULL, "main procedure missing", NULL); + return; + } + + /* + * Output array of descriptors initialized to the names of the + * global variables that have not been optimized away. + */ + if (n_glob == 0) + fprintf(codefile, "\nstruct sdescrip init_gnames[1];\n"); + else { + fprintf(codefile, "\nstruct sdescrip init_gnames[NGlobals] = {\n"); + for (i = 0; i < GHSize; i++) + for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) + if (!(gptr->flag & F_SmplInv)) + fprintf(codefile, " {%d, \"%s\"},\n", strlen(gptr->name), + gptr->name); + fprintf(codefile, " };\n"); + } + + /* + * Output array of pointers to builtin functions that correspond to + * names of the global variables. + */ + if (n_glob == 0) + fprintf(codefile, "\nstruct b_proc *builtins[1];\n"); + else { + fprintf(codefile, "\nstruct b_proc *builtins[NGlobals] = {\n"); + for (i = 0; i < GHSize; i++) + for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) + if (!(gptr->flag & F_SmplInv)) { + /* + * Need to output *something* to stay in step with other arrays. + */ + if (pfx = is_builtin(gptr)) { + fprintf(codefile, " (struct b_proc *)&BF%c%c_%s,\n", + pfx[0], pfx[1], gptr->name); + } + else + fprintf(codefile, " 0,\n"); + } + fprintf(codefile, " };\n"); + } + + /* + * Output C main function that initializes the run-time system and + * calls the main procedure. + */ + fprintf(codefile, "\n"); + fprintf(codefile, "int main(argc, argv)\n"); + fprintf(codefile, "int argc;\n"); + fprintf(codefile, "char **argv;\n"); + fprintf(codefile, " {\n"); + + /* + * If the main procedure requires a command-line argument list, we + * need a place to construct the Icon argument list. + */ + if (prc_main->nargs != 0 || !(gbl_main->flag & F_SmplInv)) { + fprintf(codefile, " struct {\n"); + fprintf(codefile, " struct tend_desc *previous;\n"); + fprintf(codefile, " int num;\n"); + fprintf(codefile, " struct descrip arg_lst;\n"); + fprintf(codefile, " } t;\n"); + fprintf(codefile, "\n"); + } + + /* + * Produce code to initialize run-time system variables. Some depend + * on compiler options. + */ + fprintf(codefile, " op_tbl = (struct b_proc *)init_op_tbl;\n"); + fprintf(codefile, " globals = (dptr)init_globals;\n"); + fprintf(codefile, " eglobals = &globals[%d];\n", n_glob); + fprintf(codefile, " gnames = (dptr)init_gnames;\n"); + fprintf(codefile, " egnames = &gnames[%d];\n", n_glob); + fprintf(codefile, " estatics = &statics[%d];\n", n_stat + 1); + if (debug_info) + fprintf(codefile, " debug_info = 1;\n"); + else + fprintf(codefile, " debug_info = 0;\n"); + if (line_info) { + fprintf(codefile, " line_info = 1;\n"); + fprintf(codefile, " file_name = \"\";\n"); + fprintf(codefile, " line_num = 0;\n"); + } + else + fprintf(codefile, " line_info = 0;\n"); + if (err_conv) + fprintf(codefile, " err_conv = 1;\n"); + else + fprintf(codefile, " err_conv = 0;\n"); + if (largeints) + fprintf(codefile, " largeints = 1;\n"); + else + fprintf(codefile, " largeints = 0;\n"); + + /* + * Produce code to call the routine to initialize the runtime system. + */ + if (trace) + fprintf(codefile, " init(*argv, &argc, argv, -1);\n"); + else + fprintf(codefile, " init(*argv, &argc, argv, 0);\n"); + fprintf(codefile, "\n"); + + /* + * If the main procedure requires an argument list (perhaps because + * it uses standard, rather than tailored calling conventions), + * set up the argument list. + */ + if (prc_main->nargs != 0 || !(gbl_main->flag & F_SmplInv)) { + fprintf(codefile, " t.arg_lst = nulldesc;\n"); + fprintf(codefile, " t.num = 1;\n"); + fprintf(codefile, " t.previous = NULL;\n"); + fprintf(codefile, " tend = (struct tend_desc *)&t;\n"); + if (prc_main->nargs == 0) + fprintf(codefile, + " /* main() takes no arguments: construct no list */\n"); + else + fprintf(codefile, " cmd_line(argc, argv, &t.arg_lst);\n"); + fprintf(codefile, "\n"); + } + else + fprintf(codefile, " tend = NULL;\n"); + + if (gbl_main->flag & F_SmplInv) { + /* + * procedure main only has a simplified implementation if it + * takes either 0 or 1 argument. + */ + first = 1; + if (prc_main->nargs == 0) + fprintf(codefile, " P%s_main(", prc_main->prefix); + else { + fprintf(codefile, " P%s_main(&t.arg_lst", prc_main->prefix); + first = 0; + } + if (prc_main->ret_flag & (DoesRet | DoesSusp)) { + if (!first) + fprintf(codefile, ", "); + fprintf(codefile, "&trashcan"); + first = 0; + } + if (prc_main->ret_flag & DoesSusp) + fprintf(codefile, ", (continuation)NULL"); + fprintf(codefile, ");\n"); + } + else /* the main procedure uses standard calling conventions */ + fprintf(codefile, + " P%s_main(1, &t.arg_lst, &trashcan, (continuation)NULL);\n", + prc_main->prefix); + fprintf(codefile, " \n"); + fprintf(codefile, " c_exit(EXIT_SUCCESS);\n"); + fprintf(codefile, " }\n"); + + /* + * Output to header file definitions related to global and static + * variables. + */ + fprintf(inclfile, "\n"); + if (n_glob == 0) { + fprintf(inclfile, "#define NGlobals 1\n"); + fprintf(inclfile, "int n_globals = 0;\n"); + } + else { + fprintf(inclfile, "#define NGlobals %d\n", n_glob); + fprintf(inclfile, "int n_globals = NGlobals;\n"); + } + ++n_stat; + fprintf(inclfile, "\n"); + fprintf(inclfile, "int n_statics = %d;\n", n_stat); + fprintf(inclfile, "struct descrip statics[%d]", MinOne(n_stat)); + if (n_stat > 0) { + fprintf(inclfile, " = {\n"); + for (i = 0; i < n_stat; ++i) + fprintf(inclfile, " {D_Null},\n"); + fprintf(inclfile, " };\n"); + } + else + fprintf(inclfile, ";\n"); + } + +/* + * proc_blk - create procedure block and initialize global variable, also + * compute offsets for local procedure variables. + */ +static void proc_blk(gptr, init_glbl) +struct gentry *gptr; +int init_glbl; + { + struct pentry *p; + register char *name; + int nquals; + + name = gptr->name; + p = gptr->val.proc; + + /* + * If we don't initialize a global variable for this procedure, we + * need only compute offsets for variables. + */ + if (init_glbl) { + fprintf(codefile, "(union block *)&BP%s_%s},\n", p->prefix, name); + nquals = 1 + Abs(p->nargs) + p->ndynam + p->nstatic; + fprintf(inclfile, "\n"); + fprintf(inclfile, "static int P%s_%s (int r_nargs, dptr r_args,", + p->prefix, name); + fprintf(inclfile, "dptr r_rslt, continuation r_s_cont);\n"); + initpblk(inclfile, 'P', p->prefix, name, nquals, p->nargs, p->ndynam, + p->nstatic, n_stat + 1); + fprintf(inclfile, "\n {%d, \"%s\"},\n", strlen(name), name); + } + arg_nms(p->args, init_glbl); + p->tnd_loc = dyn_nms(p->dynams, init_glbl); + stat_nms(p->statics, init_glbl); + if (init_glbl) + fprintf(inclfile, " }};\n"); + } + +/* + * arg_nms - compute offsets of arguments and, if needed, output the + * initializer for a descriptor for the argument name. + */ +static int arg_nms(lptr, prt) +struct lentry *lptr; +int prt; + { + register int n; + + if (lptr == NULL) + return 0; + n = arg_nms(lptr->next, prt); + lptr->val.index = n; + if (prt) + fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name); + return n + 1; + } + +/* + * dyn_nms - compute offsets of dynamic locals and, if needed, output the + * initializer for a descriptor for the variable name. + */ +static int dyn_nms(lptr, prt) +struct lentry *lptr; +int prt; + { + register int n; + + if (lptr == NULL) + return 0; + n = dyn_nms(lptr->next, prt); + lptr->val.index = n; + if (prt) + fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name); + return n + 1; + } + +/* + * stat_nams - compute offsets of static locals and, if needed, output the + * initializer for a descriptor for the variable name. + */ +static void stat_nms(lptr, prt) +struct lentry *lptr; +int prt; + { + if (lptr == NULL) + return; + stat_nms(lptr->next, prt); + lptr->val.index = ++n_stat; + if (prt) + fprintf(inclfile, " {%d, \"%s\"},\n", strlen(lptr->name), lptr->name); + } + +/* + * is_builtin - check if a global names or hides a builtin, returning prefix. + * If it hides one, we must also generate the prototype and block here. + */ +static char *is_builtin(gptr) +struct gentry *gptr; + { + struct implement *iptr; + + if (!(gptr->flag & F_StrInv)) /* if not eligible for string invoc */ + return 0; + if (gptr->flag & F_Builtin) /* if global *is* a builtin */ + return gptr->val.builtin->prefix; + iptr = db_ilkup(gptr->name, bhash); + if (iptr == NULL) /* if no builtin by this name */ + return NULL; + bi_proc(gptr->name, iptr); /* output prototype and proc block */ + return iptr->prefix; + } + +/* + * fnc_blk - output vword of descriptor for a built-in function and its + * procedure block. + */ +static void fnc_blk(gptr) +struct gentry *gptr; + { + struct implement *iptr; + char *name, *pfx; + + name = gptr->name; + iptr = gptr->val.builtin; + pfx = iptr->prefix; + /* + * output prototype and procedure block to inclfile. + */ + bi_proc(name, iptr); + /* + * vword of descriptor references the procedure block. + */ + fprintf(codefile, "(union block *)&BF%c%c_%s}, \n", pfx[0], pfx[1], name); + } + +/* + * bi_proc - output prototype and procedure block for builtin function. + */ +static void bi_proc(name, ip) +char *name; + struct implement *ip; + { + int nargs; + char prefix[3]; + + prefix[0] = ip->prefix[0]; + prefix[1] = ip->prefix[1]; + prefix[2] = '\0'; + nargs = ip->nargs; + if (nargs > 0 && ip->arg_flgs[nargs - 1] & VarPrm) + nargs = -nargs; + fprintf(inclfile, "\n"); + implproto(ip); + initpblk(inclfile, 'F', prefix, name, 1, nargs, -1, 0, 0); + fprintf(inclfile, "{%d, \"%s\"}}};\n", strlen(name), name); + } + +/* + * rec_blk - if needed, output vword of descriptor for a record + * constructor and output its procedure block. + */ +static void rec_blk(gptr, init_glbl) +struct gentry *gptr; +int init_glbl; + { + struct rentry *r; + register char *name; + int nfields; + + name = gptr->name; + r = gptr->val.rec; + nfields = r->nfields; + + /* + * If the variable is not optimized away, output vword of descriptor. + */ + if (init_glbl) + fprintf(codefile, "(union block *)&BR%s_%s},\n", r->prefix, name); + + fprintf(inclfile, "\n"); + /* + * Prototype for C function implementing constructor. If no optimizations + * have been performed on the variable, the standard calling conventions + * are used and we need a continuation parameter. + */ + fprintf(inclfile, + "static int R%s_%s (int r_nargs, dptr r_args, dptr r_rslt", + r->prefix, name); + if (init_glbl) + fprintf(inclfile, ", continuation r_s_cont"); + fprintf(inclfile, ");\n"); + + /* + * Procedure block, including record name and field names. + */ + initpblk(inclfile, 'R', r->prefix, name, nfields + 1, nfields, -2, + r->rec_num, 1); + fprintf(inclfile, "\n {%d, \"%s\"},\n", strlen(name), name); + fldnames(r->fields); + fprintf(inclfile, " }};\n"); + } + + +/* + * fldnames - output the initializer for a descriptor for the field name. + */ +static void fldnames(fields) +struct fldname *fields; + { + register char *name; + + if (fields == NULL) + return; + fldnames(fields->next); + name = fields->name; + fprintf(inclfile, " {%d, \"%s\"},\n", strlen(name), name); + } + +/* + * implproto - print prototype for function implementing a run-time operation. + */ +void implproto(ip) +struct implement *ip; + { + if (ip->iconc_flgs & ProtoPrint) + return; /* only print prototype once */ + fprintf(inclfile, "int %c%c%c_%s ", ip->oper_typ, ip->prefix[0], + ip->prefix[1], ip->name); + fprintf(inclfile, "(int r_nargs, dptr r_args, dptr r_rslt, "); + fprintf(inclfile,"continuation r_s_cont);\n"); + ip->iconc_flgs |= ProtoPrint; + } + +/* + * const_blks - output blocks for cset and real constants. + */ +void const_blks() + { + register int i; + register struct centry *cptr; + + fprintf(inclfile, "\n"); + for (i = 0; i < CHSize; i++) + for (cptr = chash[i]; cptr != NULL; cptr = cptr->blink) { + switch (cptr->flag) { + case F_CsetLit: + nxt_pre(cptr->prefix, pre, PrfxSz); + cptr->prefix[PrfxSz] = '\0'; + fprintf(inclfile, "struct b_cset BDC%s = ", cptr->prefix); + cset_init(inclfile, cptr->u.cset); + break; + case F_RealLit: + nxt_pre(cptr->prefix, pre, PrfxSz); + cptr->prefix[PrfxSz] = '\0'; + fprintf(inclfile, "struct b_real BDR%s = {T_Real, %s};\n", + cptr->prefix, cptr->image); + break; + } + } + } + +/* + * reccnstr - output record constructors. + */ +void recconstr(r) +struct rentry *r; + { + register char *name; + int optim; + int nfields; + + if (r == NULL) + return; + recconstr(r->next); + + name = r->name; + nfields = r->nfields; + + /* + * Does this record constructor use optimized calling conventions? + */ + optim = glookup(name)->flag & F_SmplInv; + + fprintf(codefile, "\n"); + fprintf(codefile, "static int R%s_%s(r_nargs, r_args, r_rslt", r->prefix, + name); + if (!optim) + fprintf(codefile, ", r_s_cont"); /* continuation is passed */ + fprintf(codefile, ")\n"); + fprintf(codefile, "int r_nargs;\n"); + fprintf(codefile, "dptr r_args;\n"); + fprintf(codefile, "dptr r_rslt;\n"); + if (!optim) + fprintf(codefile, "continuation r_s_cont;\n"); + fprintf(codefile, " {\n"); + fprintf(codefile, " register int i;\n"); + fprintf(codefile, " register struct b_record *rp;\n"); + fprintf(codefile, "\n"); + fprintf(codefile, " rp = alcrecd(%d, (union block *)&BR%s_%s);\n", + nfields, r->prefix, name); + fprintf(codefile, " if (rp == NULL) {\n"); + fprintf(codefile, " err_msg(307, NULL);\n"); + if (err_conv) + fprintf(codefile, " return A_Resume;\n"); + fprintf(codefile, " }\n"); + fprintf(codefile, " for (i = %d; i >= 0; i--)\n", nfields - 1); + fprintf(codefile, " if (i < r_nargs)\n"); + fprintf(codefile, " deref(&r_args[i], &rp->fields[i]);\n"); + fprintf(codefile, " else\n"); + fprintf(codefile, " rp->fields[i] = nulldesc;\n"); + fprintf(codefile, " r_rslt->vword.bptr = (union block *)rp;\n"); + fprintf(codefile, " r_rslt->dword = D_Record;\n"); + fprintf(codefile, " return A_Continue;\n"); + fprintf(codefile, " }\n"); + } + +/* + * outerfnc - output code for the outer function implementing a procedure. + */ +void outerfnc(fnc) +struct c_fnc *fnc; + { + char *prefix; + char *name; + char *cnt_var; + char *sep; + int ntend; + int first_arg; + int nparms; + int optim; /* optimized interface: no arg list adjustment */ + int ret_flag; +#ifdef OptimizeLoop + int i; +#endif /* OptimizeLoop */ + + prefix = cur_proc->prefix; + name = cur_proc->name; + ntend = cur_proc->tnd_loc + num_tmp; + ChkPrefix(fnc->prefix); + optim = glookup(name)->flag & F_SmplInv; + nparms = Abs(cur_proc->nargs); + ret_flag = cur_proc->ret_flag; + + fprintf(codefile, "\n"); + if (optim) { + /* + * Arg list adjustment and dereferencing are done at call site. + * Use simplified interface. Output both function header and + * prototype. + */ + sep = ""; + fprintf(inclfile, "static int P%s_%s (", prefix, name); + fprintf(codefile, "static int P%s_%s(", prefix, name); + if (nparms != 0) { + fprintf(inclfile, "dptr r_args"); + fprintf(codefile, "r_args"); + sep = ", "; + } + if (ret_flag & (DoesRet | DoesSusp)) { + fprintf(inclfile, "%sdptr r_rslt", sep); + fprintf(codefile, "%sr_rslt", sep); + sep = ", "; + } + if (ret_flag & DoesSusp) { + fprintf(inclfile, "%scontinuation r_s_cont", sep); + fprintf(codefile, "%sr_s_cont", sep); + sep = ", "; + } + if (*sep == '\0') + fprintf(inclfile, "void"); + fprintf(inclfile, ");\n"); + fprintf(codefile, ")\n"); + if (nparms != 0) + fprintf(codefile, "dptr r_args;\n"); + if (ret_flag & (DoesRet | DoesSusp)) + fprintf(codefile, "dptr r_rslt;\n"); + if (ret_flag & DoesSusp) + fprintf(codefile, "continuation r_s_cont;\n"); + } + else { + /* + * General invocation interface. Output function header; prototype has + * already been produced. + */ + fprintf(codefile, + "static int P%s_%s(r_nargs, r_args, r_rslt, r_s_cont)\n", prefix, + name); + fprintf(codefile, "int r_nargs;\n"); + fprintf(codefile, "dptr r_args;\n"); + fprintf(codefile, "dptr r_rslt;\n"); + fprintf(codefile, "continuation r_s_cont;\n"); + } + + fprintf(codefile, "{\n"); + fprintf(codefile, " struct PF%s_%s r_frame;\n", prefix, name); + fprintf(codefile, " register int r_signal;\n"); + fprintf(codefile, " int i;\n"); + if (Type(Tree1(cur_proc->tree)) != N_Empty) + fprintf(codefile, " static int first_time = 1;"); + fprintf(codefile, "\n"); + fprintf(codefile, " r_frame.old_pfp = pfp;\n"); + fprintf(codefile, " pfp = (struct p_frame *)&r_frame;\n"); + fprintf(codefile, " r_frame.old_argp = glbl_argp;\n"); + if (!optim || ret_flag & (DoesRet | DoesSusp)) + fprintf(codefile, " r_frame.rslt = r_rslt;\n"); + else + fprintf(codefile, " r_frame.rslt = NULL;\n"); + if (!optim || ret_flag & DoesSusp) + fprintf(codefile, " r_frame.succ_cont = r_s_cont;\n"); + else + fprintf(codefile, " r_frame.succ_cont = NULL;\n"); + fprintf(codefile, "\n"); +#ifdef OptimizeLoop + if (ntend > 0) { + if (ntend < LoopThreshold) + for (i=0; i < ntend ;i++) + fprintf(codefile, " r_frame.tend.d[%d] = nulldesc;\n", i); + else { + fprintf(codefile, " for (i = 0; i < %d; ++i)\n", ntend); + fprintf(codefile, " r_frame.tend.d[i] = nulldesc;\n"); + } + } +#else /* OptimizeLoop */ + fprintf(codefile, " for (i = 0; i < %d; ++i)\n", ntend); + fprintf(codefile, " r_frame.tend.d[i] = nulldesc;\n"); +#endif /* OptimizeLoop */ + if (optim) { + /* + * Dereferencing and argument list adjustment is done at the call + * site. There is not much to do here. + */ + if (nparms == 0) + fprintf(codefile, " glbl_argp = NULL;\n"); + else + fprintf(codefile, " glbl_argp = r_args;\n"); + } + else { + /* + * Dereferencing and argument list adjustment must be done by + * the procedure itself. + */ + first_arg = ntend; + ntend += nparms; + if (cur_proc->nargs < 0) { + /* + * varargs - construct a list into the last argument. + */ + nparms -= 1; + if (nparms == 0) + cnt_var = "r_nargs"; + else { + fprintf(codefile, " i = r_nargs - %d;\n", nparms); + cnt_var = "i"; + } + fprintf(codefile," if (%s <= 0)\n", cnt_var); + fprintf(codefile," varargs(NULL, 0, &r_frame.tend.d[%d]);\n", + first_arg + nparms); + fprintf(codefile," else\n"); + fprintf(codefile, + " varargs(&r_args[%d], %s, &r_frame.tend.d[%d]);\n", nparms, + cnt_var, first_arg + nparms); + } + if (nparms > 0) { + /* + * Output code to dereference argument or supply default null + * value. + */ +#ifdef OptimizeLoop + fprintf(codefile, " for (i = 0; i < r_nargs ; ++i)\n"); + fprintf(codefile, " deref(&r_args[i], &r_frame.tend.d[i + %d]);\n", first_arg); + fprintf(codefile, " for(i = r_nargs; i < %d ; ++i)\n", nparms); + fprintf(codefile, " r_frame.tend.d[i + %d] = nulldesc;\n", + first_arg); +#else /* OptimizeLoop */ + fprintf(codefile, " for (i = 0; i < %d; ++i)\n", nparms); + fprintf(codefile, " if (i < r_nargs)\n"); + fprintf(codefile, + " deref(&r_args[i], &r_frame.tend.d[i + %d]);\n", + first_arg); + fprintf(codefile, " else\n"); + fprintf(codefile, " r_frame.tend.d[i + %d] = nulldesc;\n", + first_arg); +#endif /* OptimizeLoop */ + } + fprintf(codefile, " glbl_argp = &r_frame.tend.d[%d];\n", first_arg); + } + fprintf(codefile, " r_frame.tend.num = %d;\n", ntend); + fprintf(codefile, " r_frame.tend.previous = tend;\n"); + fprintf(codefile, " tend = (struct tend_desc *)&r_frame.tend;\n"); + if (line_info) { + fprintf(codefile, " r_frame.debug.old_line = line_num;\n"); + fprintf(codefile, " r_frame.debug.old_fname = file_name;\n"); + } + if (debug_info) { + fprintf(codefile, " r_frame.debug.proc = (struct b_proc *)&BP%s_%s;\n", + prefix, name); + fprintf(codefile, " if (k_trace) ctrace();\n"); + fprintf(codefile, " ++k_level;\n\n"); + } + fprintf(codefile, "\n"); + + /* + * Output definition for procedure frame. + */ + prt_frame(prefix, ntend, num_itmp, num_dtmp, num_sbuf, num_cbuf); + + /* + * Output code to implement procedure body. + */ + prtcode(&(fnc->cd), 1); + fprintf(codefile, " }\n"); + } + +/* + * prt_fnc - output C function that implements a continuation. + */ +void prt_fnc(fnc) +struct c_fnc *fnc; + { + struct code *sig; + char *name; + char *prefix; + + if (fnc->flag & CF_SigOnly) { + /* + * This function only returns a signal. A shared function is used in + * its place. Make sure that function has been printed. + */ + sig = fnc->cd.next->SigRef->sig; + if (sig->cd_id != C_Resume) { + sig = ChkBound(sig); + if (!(sig->LabFlg & FncPrtd)) { + ChkSeqNum(sig); + fprintf(inclfile, "static int sig_%d (void);\n", + sig->SeqNum); + + fprintf(codefile, "\n"); + fprintf(codefile, "static int sig_%d()\n", sig->SeqNum); + fprintf(codefile, " {\n"); + fprintf(codefile, " return %d; /* %s */\n", sig->SeqNum, + sig->Desc); + fprintf(codefile, " }\n"); + sig->LabFlg |= FncPrtd; + } + } + } + else { + ChkPrefix(fnc->prefix); + prefix = fnc->prefix; + name = cur_proc->name; + + fprintf(inclfile, "static int P%s_%s (void);\n", prefix, name); + + fprintf(codefile, "\n"); + fprintf(codefile, "static int P%s_%s()\n", prefix, name); + fprintf(codefile, " {\n"); + if (fnc->flag & CF_Coexpr) + fprintf(codefile, "#ifdef Coexpr\n"); + + prefix = fnc->frm_prfx; + + fprintf(codefile, " register int r_signal;\n"); + fprintf(codefile, " register struct PF%s_%s *r_pfp;\n", prefix, name); + fprintf(codefile, "\n"); + fprintf(codefile, " r_pfp = (struct PF%s_%s *)pfp;\n", prefix, name); + prtcode(&(fnc->cd), 0); + if (fnc->flag & CF_Coexpr) { + fprintf(codefile, "#else\t\t\t\t\t/* Coexpr */\n"); + fprintf(codefile, " fatalerr(401, NULL);\n"); + fprintf(codefile, "#endif\t\t\t\t\t/* Coexpr */\n"); + } + fprintf(codefile, " }\n"); + } + } + +/* + * prt_frame - output the definition for a procedure frame. + */ +void prt_frame(prefix, ntend, n_itmp, n_dtmp, n_sbuf, n_cbuf) +char *prefix; +int ntend; +int n_itmp; +int n_dtmp; +int n_sbuf; +int n_cbuf; + { + int i; + + /* + * Output standard part of procedure frame including tended + * descriptors. + */ + fprintf(inclfile, "\n"); + fprintf(inclfile, "struct PF%s_%s {\n", prefix, cur_proc->name); + fprintf(inclfile, " struct p_frame *old_pfp;\n"); + fprintf(inclfile, " dptr old_argp;\n"); + fprintf(inclfile, " dptr rslt;\n"); + fprintf(inclfile, " continuation succ_cont;\n"); + fprintf(inclfile, " struct {\n"); + fprintf(inclfile, " struct tend_desc *previous;\n"); + fprintf(inclfile, " int num;\n"); + fprintf(inclfile, " struct descrip d[%d];\n", MinOne(ntend)); + fprintf(inclfile, " } tend;\n"); + + if (line_info) { /* must be true if debug_info is true */ + fprintf(inclfile, " struct debug debug;\n"); + } + + /* + * Output declarations for the integer, double, string buffer, + * and cset buffer work areas of the frame. + */ + for (i = 0; i < n_itmp; ++i) + fprintf(inclfile, " word i%d;\n", i); + for (i = 0; i < n_dtmp; ++i) + fprintf(inclfile, " double d%d;\n", i); + if (n_sbuf > 0) + fprintf(inclfile, " char sbuf[%d][MaxCvtLen];", n_sbuf); + if (n_cbuf > 0) + fprintf(inclfile, " struct b_cset cbuf[%d];", n_cbuf); + fprintf(inclfile, " };\n"); + } + +/* + * prtcode - print a list of C code. + */ +static void prtcode(cd, outer) +struct code *cd; +int outer; + { + struct lentry *var; + struct centry *lit; + struct code *sig; + int n; + + for ( ; cd != NULL; cd = cd->next) { + switch (cd->cd_id) { + case C_Null: + break; + + case C_NamedVar: + /* + * Construct a reference to a named variable in a result + * location. + */ + var = cd->NamedVar; + fprintf(codefile, " "); + val_loc(cd->Rslt, outer); + fprintf(codefile, ".dword = D_Var;\n"); + fprintf(codefile, " "); + val_loc(cd->Rslt, outer); + fprintf(codefile, ".vword.descptr = &"); + prt_var(var, outer); + fprintf(codefile, ";\n"); + break; + + case C_CallSig: + /* + * Call to C function that returns a signal along with signal + * handling code. + */ + if (opt_sgnl) + good_clsg(cd, outer); + else + smpl_clsg(cd, outer); + break; + + case C_RetSig: + /* + * Return a signal. + */ + sig = cd->SigRef->sig; + if (sig->cd_id == C_Resume) + fprintf(codefile, " return A_Resume;\n"); + else { + sig = ChkBound(sig); + ChkSeqNum(sig); + fprintf(codefile, " return %d; /* %s */\n", sig->SeqNum, + sig->Desc); + } + break; + + case C_Goto: + /* + * goto label. + */ + ChkSeqNum(cd->Lbl); + fprintf(codefile, " goto L%d /* %s */;\n", cd->Lbl->SeqNum, + cd->Lbl->Desc); + break; + + case C_Label: + /* + * numbered label. + */ + if (cd->RefCnt > 0) { + ChkSeqNum(cd); + fprintf(codefile, "L%d: ; /* %s */\n", cd->SeqNum, cd->Desc); + } + break; + + case C_Lit: + /* + * Assign literal value to a result location. + */ + lit = cd->Literal; + fprintf(codefile, " "); + val_loc(cd->Rslt, outer); + switch (lit->flag) { + case F_CsetLit: + fprintf(codefile, ".dword = D_Cset;\n"); + fprintf(codefile, " "); + val_loc(cd->Rslt, outer); + fprintf(codefile, ".vword.bptr = (union block *)&BDC%s;\n", + lit->prefix); + break; + case F_IntLit: + if (lit->u.intgr == -1) { + /* + * Large integer literal - output string and convert + * to integer. + */ + fprintf(codefile, ".vword.sptr = \"%s\";\n", lit->image); + fprintf(codefile, " "); + val_loc(cd->Rslt, outer); + fprintf(codefile, ".dword = %d;\n", strlen(lit->image)); + fprintf(codefile, " cnv_int(&"); + val_loc(cd->Rslt, outer); + fprintf(codefile, ", &"); + val_loc(cd->Rslt, outer); + fprintf(codefile, ");\n"); + } + else { + /* + * Ordinary integer literal. + */ + fprintf(codefile, ".dword = D_Integer;\n"); + fprintf(codefile, " "); + val_loc(cd->Rslt, outer); + fprintf(codefile, ".vword.integr = %ld;\n", lit->u.intgr); + } + break; + case F_RealLit: + fprintf(codefile, ".dword = D_Real;\n"); + fprintf(codefile, " "); + val_loc(cd->Rslt, outer); + fprintf(codefile, ".vword.bptr = (union block *)&BDR%s;\n", + lit->prefix); + break; + case F_StrLit: + fprintf(codefile, ".vword.sptr = "); + if (lit->length == 0) { + /* + * Placing an empty string at the end of the string region + * allows some concatenation optimizations at run time. + */ + fprintf(codefile, "strfree;\n"); + n = 0; + } + else { + fprintf(codefile, "\""); + n = prt_i_str(codefile, lit->image, lit->length); + fprintf(codefile, "\";\n"); + } + fprintf(codefile, " "); + val_loc(cd->Rslt, outer); + fprintf(codefile, ".dword = %d;\n", n); + break; + } + break; + + case C_PFail: + /* + * Procedure failure - this code occurs once near the end of + * the procedure. + */ + if (debug_info) { + fprintf(codefile, " --k_level;\n"); + fprintf(codefile, " if (k_trace) failtrace();\n"); + } + fprintf(codefile, " tend = r_frame.tend.previous;\n"); + fprintf(codefile, " pfp = r_frame.old_pfp;\n"); + fprintf(codefile, " glbl_argp = r_frame.old_argp;\n"); + if (line_info) { + fprintf(codefile, " line_num = r_frame.debug.old_line;\n"); + fprintf(codefile, " file_name = r_frame.debug.old_fname;\n"); + } + fprintf(codefile, " return A_Resume;\n"); + break; + + case C_PRet: + /* + * Procedure return - this code occurs once near the end of + * the procedure. + */ + if (debug_info) { + fprintf(codefile, " --k_level;\n"); + fprintf(codefile, " if (k_trace) rtrace();\n"); + } + fprintf(codefile, " tend = r_frame.tend.previous;\n"); + fprintf(codefile, " pfp = r_frame.old_pfp;\n"); + fprintf(codefile, " glbl_argp = r_frame.old_argp;\n"); + if (line_info) { + fprintf(codefile, " line_num = r_frame.debug.old_line;\n"); + fprintf(codefile, " file_name = r_frame.debug.old_fname;\n"); + } + fprintf(codefile, " return A_Continue;\n"); + break; + + case C_PSusp: + /* + * Procedure suspend - call success continuation. + */ + prtpccall(outer); + break; + + case C_Break: + fprintf(codefile, " break;\n"); + break; + + case C_If: + /* + * C if statement. + */ + fprintf(codefile, " if ("); + prt_ary(cd->Cond, outer); + fprintf(codefile, ")\n "); + prtcode(cd->ThenStmt, outer); + break; + + case C_CdAry: + /* + * Array of code fragments. + */ + fprintf(codefile, " "); + prt_ary(cd, outer); + fprintf(codefile, "\n"); + break; + + case C_LBrack: + fprintf(codefile, " {\n"); + break; + + case C_RBrack: + fprintf(codefile, " }\n"); + break; + + case C_Create: + /* + * Code to create a co-expression and assign it to a result + * location. + */ + fprintf(codefile, " "); + val_loc(cd->Rslt, outer); + fprintf(codefile , ".vword.bptr = (union block *)create("); + prt_cont(cd->Cont); + fprintf(codefile, + ", (struct b_proc *)&BP%s_%s, %d, sizeof(word) * %d);\n", + cur_proc->prefix, cur_proc->name, cd->NTemps, cd->WrkSize); + fprintf(codefile, " "); + val_loc(cd->Rslt, outer); + fprintf(codefile, ".dword = D_Coexpr;\n"); + break; + + case C_SrcLoc: + /* + * Update file name and line number information. + */ + if (cd->FileName != NULL) { + fprintf(codefile, " file_name = \""); + prt_i_str(codefile, cd->FileName, strlen(cd->FileName)); + fprintf(codefile, "\";\n"); + } + if (cd->LineNum != 0) + fprintf(codefile, " line_num = %d;\n", cd->LineNum); + break; + } + } + } + +/* + * prt_var - output C code to reference an Icon named variable. + */ +static void prt_var(var, outer) +struct lentry *var; +int outer; + { + switch (var->flag) { + case F_Global: + fprintf(codefile, "globals[%d]", var->val.global->index); + break; + case F_Static: + fprintf(codefile, "statics[%d]", var->val.index); + break; + case F_Dynamic: + frame(outer); + fprintf(codefile, ".tend.d[%d]", var->val.index); + break; + case F_Argument: + fprintf(codefile, "glbl_argp[%d]", var->val.index); + } + + /* + * Include an identifying comment. + */ + fprintf(codefile, " /* %s */", var->name); + } + +/* + * prt_ary - print an array of code fragments. + */ +static void prt_ary(cd, outer) +struct code *cd; +int outer; + { + int i; + + for (i = 0; cd->ElemTyp(i) != A_End; ++i) + switch (cd->ElemTyp(i)) { + case A_Str: + /* + * Simple C code in a string. + */ + fprintf(codefile, "%s", cd->Str(i)); + break; + case A_ValLoc: + /* + * Value location (usually variable of some sort). + */ + val_loc(cd->ValLoc(i), outer); + break; + case A_Intgr: + /* + * Integer. + */ + fprintf(codefile, "%d", cd->Intgr(i)); + break; + case A_ProcCont: + /* + * Current procedure call's success continuation. + */ + if (outer) + fprintf(codefile, "r_s_cont"); + else + fprintf(codefile, "r_pfp->succ_cont"); + break; + case A_SBuf: + /* + * One of the string buffers. + */ + frame(outer); + fprintf(codefile, ".sbuf[%d]", cd->Intgr(i)); + break; + case A_CBuf: + /* + * One of the cset buffers. + */ + fprintf(codefile, "&("); + frame(outer); + fprintf(codefile, ".cbuf[%d])", cd->Intgr(i)); + break; + case A_Ary: + /* + * A subarray of code fragments. + */ + prt_ary(cd->Array(i), outer); + break; + } + } + +/* + * frame - access to the procedure frame. Access directly from outer function, + * but access through r_pfp from a continuation. + */ +static void frame(outer) +int outer; + { + if (outer) + fprintf(codefile, "r_frame"); + else + fprintf(codefile, "(*r_pfp)"); + } + +/* + * prtpccall - print procedure continuation call. + */ +static void prtpccall(outer) +int outer; + { + int first_arg; + int optim; /* optimized interface: no arg list adjustment */ + + first_arg = cur_proc->tnd_loc + num_tmp; + optim = glookup(cur_proc->name)->flag & F_SmplInv; + + /* + * The only signal to be handled in this procedure is + * resumption, the rest must be passed on. + */ + if (cur_proc->nargs != 0 && optim && !outer) { + fprintf(codefile, " {\n"); + fprintf(codefile, " dptr r_argp_sav;\n"); + fprintf(codefile, "\n"); + fprintf(codefile, " r_argp_sav = glbl_argp;\n"); + } + if (debug_info) { + fprintf(codefile, " --k_level;\n"); + fprintf(codefile, " if (k_trace) strace();\n"); + } + fprintf(codefile, " pfp = "); + frame(outer); + fprintf(codefile, ".old_pfp;\n"); + fprintf(codefile, " glbl_argp = "); + frame(outer); + fprintf(codefile, ".old_argp;\n"); + if (line_info) { + fprintf(codefile, " line_num = "); + frame(outer); + fprintf(codefile, ".debug.old_line;\n"); + fprintf(codefile, " file_name = "); + frame(outer); + fprintf(codefile , ".debug.old_fname;\n"); + } + fprintf(codefile, " r_signal = (*"); + if (outer) + fprintf(codefile, "r_s_cont)();\n"); + else + fprintf(codefile, "r_pfp->succ_cont)();\n"); + fprintf(codefile, " if (r_signal != A_Resume) {\n"); + if (outer) + fprintf(codefile, " tend = r_frame.tend.previous;\n"); + fprintf(codefile, " return r_signal;\n"); + fprintf(codefile, " }\n"); + fprintf(codefile, " pfp = (struct p_frame *)&"); + frame(outer); + fprintf(codefile, ";\n"); + if (cur_proc->nargs == 0) + fprintf(codefile, " glbl_argp = NULL;\n"); + else { + if (optim) { + if (outer) + fprintf(codefile, " glbl_argp = r_args;\n"); + else + fprintf(codefile, " glbl_argp = r_argp_sav;\n"); + } + else { + fprintf(codefile, " glbl_argp = &"); + if (outer) + fprintf(codefile, "r_frame."); + else + fprintf(codefile, "r_pfp->"); + fprintf(codefile, "tend.d[%d];\n", first_arg); + } + } + if (debug_info) { + fprintf(codefile, " if (k_trace) atrace();\n"); + fprintf(codefile, " ++k_level;\n"); + } + if (cur_proc->nargs != 0 && optim && !outer) + fprintf(codefile, " }\n"); + } + +/* + * smpl_clsg - print call and signal handling code, but nothing fancy. + */ +static void smpl_clsg(call, outer) +struct code *call; +int outer; + { + struct sig_act *sa; + + fprintf(codefile, " r_signal = "); + prtcall(call, outer); + fprintf(codefile, ";\n"); + if (call->Flags & ForeignSig) + chkforgn(outer); + fprintf(codefile, " switch (r_signal) {\n"); + for (sa = call->SigActs; sa != NULL; sa = sa->next) { + fprintf(codefile, " case "); + prt_cond(sa->sig); + fprintf(codefile, ":\n "); + prtcode(sa->cd, outer); + } + fprintf(codefile, " }\n"); + } + +/* + * chkforgn - produce code to see if the current signal belongs to a + * procedure higher up the call chain and pass it along if it does. + */ +static void chkforgn(outer) +int outer; + { + fprintf(codefile, " if (pfp != (struct p_frame *)"); + if (outer) { + fprintf(codefile, "&r_frame) {\n"); + fprintf(codefile, " tend = r_frame.tend.previous;\n"); + } + else + fprintf(codefile, "r_pfp) {\n"); + fprintf(codefile, " return r_signal;\n"); + fprintf(codefile, " }\n"); + } + +/* + * good_clsg - print call and signal handling code and do a good job. + */ +static void good_clsg(call, outer) +struct code *call; +int outer; + { + struct sig_act *sa, *sa1, *nxt_sa; + int ncases; /* the number of cases - each may have multiple case labels */ + int ncaselbl; /* the number of case labels */ + int nbreak; /* the number of cases that just break out of the switch */ + int nretsig; /* the number of cases that just pass along signal */ + int sig_var; + int dflt; + struct code *cond; + struct code *then_cd; + + /* + * Decide whether to use "break;", "return r_signal;", or nothing as + * the default case. + */ + nretsig = 0; + nbreak = 0; + for (sa = call->SigActs; sa != NULL; sa = sa->next) { + if (sa->cd->cd_id == C_RetSig && sa->sig == sa->cd->SigRef->sig) { + /* + * The action returns the same signal detected by this case. + */ + ++nretsig; + } + else if (sa->cd->cd_id == C_Break) { + cond = sa->sig; /* if there is only one break, we may want this */ + ++nbreak; + } + } + dflt = DfltNone; + ncases = 0; + if (nbreak > 0 && nbreak >= nretsig) { + /* + * There are at least as many "break;"s as "return r_signal;"s, so + * use "break;" for default clause. + */ + dflt = DfltBrk; + ncases = 1; + } + else if (nretsig > 1) { + /* + * There is more than one case that returns the same signal it + * detects and there are more of them than "break;"s, to make + * "return r_signal;" the default clause. + */ + dflt = DfltRetSig; + ncases = 1; + } + + /* + * Gather case labels together for each case, ignoring cases that + * fall under the default. This involves constructing a new + * improved call->SigActs list. + */ + ncaselbl = ncases; + sa = call->SigActs; + call->SigActs = NULL; + for ( ; sa != NULL; sa = nxt_sa) { + nxt_sa = sa->next; + /* + * See if we have already found a case with the same action. + */ + sa1 = call->SigActs; + switch (sa->cd->cd_id) { + case C_Break: + if (dflt == DfltBrk) + continue; + while (sa1 != NULL && sa1->cd->cd_id != C_Break) + sa1 = sa1->next; + break; + case C_RetSig: + if (dflt == DfltRetSig && sa->cd->SigRef->sig == sa->sig) + continue; + while (sa1 != NULL && (sa1->cd->cd_id != C_RetSig || + sa1->cd->SigRef->sig != sa->cd->SigRef->sig)) + sa1 = sa1->next; + break; + default: /* C_Goto */ + while (sa1 != NULL && (sa1->cd->cd_id != C_Goto || + sa1->cd->Lbl != sa->cd->Lbl)) + sa1 = sa1->next; + break; + } + ++ncaselbl; + if (sa1 == NULL) { + /* + * First time we have seen this action, create a new case. + */ + ++ncases; + sa->next = call->SigActs; + call->SigActs = sa; + } + else { + /* + * We can share the action of another case label. + */ + sa->shar_act = sa1->shar_act; + sa1->shar_act = sa; + } + } + + /* + * If we might receive a "foreign" signal that belongs to a procedure + * further down the call chain, put the signal in "r_signal" then + * check for this condition. + */ + sig_var = 0; + if (call->Flags & ForeignSig) { + fprintf(codefile, " r_signal = "); + prtcall(call, outer); + fprintf(codefile, ";\n"); + chkforgn(outer); + sig_var = 1; + } + + /* + * Determine the best way to handle the signal returned from the call. + */ + if (ncases == 0) { + /* + * Any further signal checking has been optimized away. Execution + * just falls through to subsequent code. If the call has not + * been done, do it. + */ + if (!sig_var) { + fprintf(codefile, " "); + prtcall(call, outer); + fprintf(codefile, ";\n"); + } + } + else if (ncases == 1) { + if (dflt == DfltRetSig || ncaselbl == nretsig) { + /* + * All this call does is pass the signal on. See if we have + * done the call yet. + */ + if (sig_var) + fprintf(codefile, " return r_signal;"); + else { + fprintf(codefile, " return "); + prtcall(call, outer); + fprintf(codefile, ";\n"); + } + } + else { + /* + * We know what to do without looking at the signal. Make sure + * we have done the call. If the action is not simply "break" + * out signal checking, execute it. + */ + if (!sig_var) { + fprintf(codefile, " "); + prtcall(call, outer); + fprintf(codefile, ";\n"); + } + if (dflt != DfltBrk) + prtcode(call->SigActs->cd, outer); + } + } + else { + /* + * We have at least two cases. If we have a default action of returning + * the signal without looking at it, make sure it is in "r_signal". + */ + if (!sig_var && dflt == DfltRetSig) { + fprintf(codefile, " r_signal = "); + prtcall(call, outer); + fprintf(codefile, ";\n"); + sig_var = 1; + } + + if (ncaselbl == 2) { + /* + * We can use an if statement. If we need the signal in "r_signal", + * it is already there. + */ + fprintf(codefile, " if ("); + if (sig_var) + fprintf(codefile, "r_signal"); + else + prtcall(call, outer); + + cond = call->SigActs->sig; + then_cd = call->SigActs->cd; + + /* + * If the "then" clause is a no-op ("break;" from a switch), + * prepare to eliminate it by reversing the test in the + * condition. + */ + if (then_cd->cd_id == C_Break) + fprintf(codefile, " != "); + else + fprintf(codefile, " == "); + + prt_cond(cond); + fprintf(codefile, ")\n "); + + if (then_cd->cd_id == C_Break) { + /* + * We have reversed the test, so we need to use the default + * code. However, because a "break;" exists and it is not + * default, "return r_signal;" must be the default. + */ + fprintf(codefile, " return r_signal;\n"); + } + else { + /* + * Print the "then" clause and determine what the "else" clause + * is. + */ + prtcode(then_cd, outer); + if (call->SigActs->next != NULL) { + fprintf(codefile, " else\n "); + prtcode(call->SigActs->next->cd, outer); + } + else if (dflt == DfltRetSig) { + fprintf(codefile, " else\n"); + fprintf(codefile, " return r_signal;\n"); + } + } + } + else if (ncases == 2 && nbreak == 1) { + /* + * We can use an if-then statement with a negated test. Note, + * the non-break case is not "return r_signal" or we would have + * ncaselbl = 2, making the last test true. This also means that + * break is the default (the break condition was saved). + */ + fprintf(codefile, " if ("); + if (sig_var) + fprintf(codefile, "r_signal"); + else + prtcall(call, outer); + fprintf(codefile, " != "); + prt_cond(cond); + fprintf(codefile, ") {\n "); + prtcode(call->SigActs->cd, outer); + fprintf(codefile, " }\n"); + } + else { + /* + * We must use a full case statement. If we need the signal in + * "r_signal", it is already there. + */ + fprintf(codefile, " switch ("); + if (sig_var) + fprintf(codefile, "r_signal"); + else + prtcall(call, outer); + fprintf(codefile, ") {\n"); + + /* + * Print the cases + */ + for (sa = call->SigActs; sa != NULL; sa = sa->next) { + for (sa1 = sa; sa1 != NULL; sa1 = sa1->shar_act) { + fprintf(codefile, " case "); + prt_cond(sa1->sig); + fprintf(codefile, ":\n"); + } + fprintf(codefile, " "); + prtcode(sa->cd, outer); + } + + /* + * If we have a default action and it is not break, print it. + */ + if (dflt == DfltRetSig) { + fprintf(codefile, " default:\n"); + fprintf(codefile, " return r_signal;\n"); + } + + fprintf(codefile, " }\n"); + } + } + } + +/* + * prtcall - print call. + */ +static void prtcall(call, outer) +struct code *call; +int outer; + { + /* + * Either the operation or the continuation may be missing, but not + * both. + */ + if (call->OperName == NULL) { + prt_cont(call->Cont); + fprintf(codefile, "()"); + } + else { + fprintf(codefile, "%s(", call->OperName); + if (call->ArgLst != NULL) + prt_ary(call->ArgLst, outer); + if (call->Cont == NULL) { + if (call->Flags & NeedCont) { + /* + * The operation requires a continuation argument even though + * this call does not include one, pass the NULL pointer. + */ + if (call->ArgLst != NULL) + fprintf(codefile, ", "); + fprintf(codefile, "(continuation)NULL"); + } + } + else { + /* + * Pass the success continuation. + */ + if (call->ArgLst != NULL) + fprintf(codefile, ", "); + prt_cont(call->Cont); + } + fprintf(codefile, ")"); + } + } + +/* + * prt_cont - print the name of a continuation. + */ +static void prt_cont(cont) +struct c_fnc *cont; + { + struct code *sig; + + if (cont->flag & CF_SigOnly) { + /* + * This continuation only returns a signal. All continuations + * returning the same signal are implemented by the same C function. + */ + sig = cont->cd.next->SigRef->sig; + if (sig->cd_id == C_Resume) + fprintf(codefile, "sig_rsm"); + else { + sig = ChkBound(sig); + ChkSeqNum(sig); + fprintf(codefile, "sig_%d", sig->SeqNum); + } + } + else { + /* + * Regular continuation. + */ + ChkPrefix(cont->prefix); + fprintf(codefile, "P%s_%s", cont->prefix, cur_proc->name); + } + } + +/* + * val_loc - output code referencing a value location (usually variable of + * some sort). + */ +static void val_loc(loc, outer) +struct val_loc *loc; +int outer; + { + /* + * See if we need to cast a block pointer to a specific block type + * or if we need to take the address of a location. + */ + if (loc->mod_access == M_BlkPtr && loc->blk_name != NULL) + fprintf(codefile, "(*(struct %s **)&", loc->blk_name); + if (loc->mod_access == M_Addr) + fprintf(codefile, "(&"); + + switch (loc->loc_type) { + case V_Ignore: + fprintf(codefile, "trashcan"); + break; + case V_Temp: + /* + * Temporary descriptor variable. + */ + frame(outer); + fprintf(codefile, ".tend.d[%d]", cur_proc->tnd_loc + loc->u.tmp); + break; + case V_ITemp: + /* + * Temporary C integer variable. + */ + frame(outer); + fprintf(codefile, ".i%d", loc->u.tmp); + break; + case V_DTemp: + /* + * Temporary C double variable. + */ + frame(outer); + fprintf(codefile, ".d%d", loc->u.tmp); + break; + case V_Const: + /* + * Integer constant (used for size of variable part of arg list). + */ + fprintf(codefile, "%d", loc->u.int_const); + break; + case V_NamedVar: + /* + * Icon named variable. + */ + prt_var(loc->u.nvar, outer); + break; + case V_CVar: + /* + * C variable from in-line code. + */ + fprintf(codefile, "%s", loc->u.name); + break; + case V_PRslt: + /* + * Procedure result location. + */ + if (!outer) + fprintf(codefile, "(*r_pfp->rslt)"); + else + fprintf(codefile, "(*r_rslt)"); + break; + } + + /* + * See if we are accessing the vword of a descriptor. + */ + switch (loc->mod_access) { + case M_CharPtr: + fprintf(codefile, ".vword.sptr"); + break; + case M_BlkPtr: + fprintf(codefile, ".vword.bptr"); + if (loc->blk_name != NULL) + fprintf(codefile, ")"); + break; + case M_CInt: + fprintf(codefile, ".vword.integr"); + break; + case M_Addr: + fprintf(codefile, ")"); + break; + } + } + +/* + * prt_cond - print a condition (signal number). + */ +static void prt_cond(cond) +struct code *cond; + { + if (cond == &resume) + fprintf(codefile, "A_Resume"); + else if (cond == &contin) + fprintf(codefile, "A_Continue"); + else if (cond == &fallthru) + fprintf(codefile, "A_FallThru"); + else { + cond = ChkBound(cond); + ChkSeqNum(cond); + fprintf(codefile, "%d /* %s */", cond->SeqNum, cond->Desc); + } + } + +/* + * initpblk - write a procedure block along with initialization up to the + * the array of qualifiers. + */ +static void initpblk(f, c, prefix, name, nquals, nparam, ndynam, nstatic, + frststat) +FILE *f; /* output file */ +int c; /* distinguishes procedures, functions, record constructors */ +char* prefix; /* prefix for name */ +char *name; /* name of routine */ +int nquals; /* number of qualifiers at end of block */ +int nparam; /* number of parameters */ +int ndynam; /* number of dynamic locals or function/record indicator */ +int nstatic; /* number of static locals or record number */ +int frststat; /* index into static array of first static local */ + { + fprintf(f, "B_IProc(%d) B%c%s_%s = ", nquals, c, prefix, name); + fprintf(f, "{T_Proc, %d, %c%s_%s, %d, %d, %d, %d, {", 9 + 2 * nquals, c, + prefix, name, nparam, ndynam, nstatic, frststat); + } + diff --git a/src/iconc/cparse.c b/src/iconc/cparse.c new file mode 100644 index 0000000..b29986d --- /dev/null +++ b/src/iconc/cparse.c @@ -0,0 +1,1940 @@ +# define IDENT 257 +# define INTLIT 258 +# define REALLIT 259 +# define STRINGLIT 260 +# define CSETLIT 261 +# define EOFX 262 +# define BREAK 263 +# define BY 264 +# define CASE 265 +# define CREATE 266 +# define DEFAULT 267 +# define DO 268 +# define ELSE 269 +# define END 270 +# define EVERY 271 +# define FAIL 272 +# define GLOBAL 273 +# define IF 274 +# define INITIAL 275 +# define INVOCABLE 276 +# define LINK 277 +# define LOCAL 278 +# define NEXT 279 +# define NOT 280 +# define OF 281 +# define PROCEDURE 282 +# define RECORD 283 +# define REPEAT 284 +# define RETURN 285 +# define STATIC 286 +# define SUSPEND 287 +# define THEN 288 +# define TO 289 +# define UNTIL 290 +# define WHILE 291 +# define BANG 292 +# define MOD 293 +# define AUGMOD 294 +# define AND 295 +# define AUGAND 296 +# define STAR 297 +# define AUGSTAR 298 +# define INTER 299 +# define AUGINTER 300 +# define PLUS 301 +# define AUGPLUS 302 +# define UNION 303 +# define AUGUNION 304 +# define MINUS 305 +# define AUGMINUS 306 +# define DIFF 307 +# define AUGDIFF 308 +# define DOT 309 +# define SLASH 310 +# define AUGSLASH 311 +# define ASSIGN 312 +# define SWAP 313 +# define NMLT 314 +# define AUGNMLT 315 +# define REVASSIGN 316 +# define REVSWAP 317 +# define SLT 318 +# define AUGSLT 319 +# define SLE 320 +# define AUGSLE 321 +# define NMLE 322 +# define AUGNMLE 323 +# define NMEQ 324 +# define AUGNMEQ 325 +# define SEQ 326 +# define AUGSEQ 327 +# define EQUIV 328 +# define AUGEQUIV 329 +# define NMGT 330 +# define AUGNMGT 331 +# define NMGE 332 +# define AUGNMGE 333 +# define SGT 334 +# define AUGSGT 335 +# define SGE 336 +# define AUGSGE 337 +# define QMARK 338 +# define AUGQMARK 339 +# define AT 340 +# define AUGAT 341 +# define BACKSLASH 342 +# define CARET 343 +# define AUGCARET 344 +# define BAR 345 +# define CONCAT 346 +# define AUGCONCAT 347 +# define LCONCAT 348 +# define AUGLCONCAT 349 +# define TILDE 350 +# define NMNE 351 +# define AUGNMNE 352 +# define SNE 353 +# define AUGSNE 354 +# define NEQUIV 355 +# define AUGNEQUIV 356 +# define LPAREN 357 +# define RPAREN 358 +# define PCOLON 359 +# define COMMA 360 +# define MCOLON 361 +# define COLON 362 +# define SEMICOL 363 +# define LBRACK 364 +# define RBRACK 365 +# define LBRACE 366 +# define RBRACE 367 + +# line 145 "cgram.g" +/* + * These commented directives are passed through the first application + * of cpp, then turned into real directives in cgram.g by fixgram.icn. + */ +#include "../h/gsupport.h" +#include "../h/lexdef.h" +#include "ctrans.h" +#include "csym.h" +#include "ctree.h" +#include "ccode.h" +#include "cproto.h" +#undef YYSTYPE +#define YYSTYPE nodeptr +#define YYMAXDEPTH 500 + +int idflag; + + + +#define yyclearin yychar = -1 +#define yyerrok yyerrflag = 0 +extern int yychar; +extern int yyerrflag; +#ifndef YYMAXDEPTH +#define YYMAXDEPTH 150 +#endif +#ifndef YYSTYPE +#define YYSTYPE int +#endif +YYSTYPE yylval, yyval; +# define YYERRCODE 256 + +# line 441 "cgram.g" + + +/* + * xfree(p) -- used with free(p) macro to avoid compiler errors from + * miscast free calls generated by Yacc. + */ + +static void xfree(p) +char *p; +{ + free(p); +} + +#define free(p) xfree((char*)p) +int yyexca[] ={ +-1, 0, + 262, 2, + 273, 2, + 276, 2, + 277, 2, + 282, 2, + 283, 2, + -2, 0, +-1, 1, + 0, -1, + -2, 0, +-1, 20, + 270, 40, + 363, 42, + -2, 0, +-1, 86, + 264, 42, + 268, 42, + 269, 42, + 281, 42, + 288, 42, + 289, 42, + 293, 42, + 294, 42, + 296, 42, + 298, 42, + 300, 42, + 302, 42, + 304, 42, + 306, 42, + 308, 42, + 311, 42, + 312, 42, + 313, 42, + 314, 42, + 315, 42, + 316, 42, + 317, 42, + 318, 42, + 319, 42, + 320, 42, + 321, 42, + 322, 42, + 323, 42, + 325, 42, + 327, 42, + 329, 42, + 330, 42, + 331, 42, + 332, 42, + 333, 42, + 334, 42, + 335, 42, + 336, 42, + 337, 42, + 339, 42, + 341, 42, + 344, 42, + 347, 42, + 349, 42, + 352, 42, + 354, 42, + 356, 42, + 358, 42, + 359, 42, + 360, 42, + 361, 42, + 362, 42, + 363, 42, + 365, 42, + 367, 42, + -2, 0, +-1, 87, + 358, 42, + 360, 42, + -2, 0, +-1, 88, + 363, 42, + 367, 42, + -2, 0, +-1, 89, + 360, 42, + 365, 42, + -2, 0, +-1, 96, + 264, 42, + 268, 42, + 269, 42, + 281, 42, + 288, 42, + 289, 42, + 293, 42, + 294, 42, + 296, 42, + 298, 42, + 300, 42, + 302, 42, + 304, 42, + 306, 42, + 308, 42, + 311, 42, + 312, 42, + 313, 42, + 314, 42, + 315, 42, + 316, 42, + 317, 42, + 318, 42, + 319, 42, + 320, 42, + 321, 42, + 322, 42, + 323, 42, + 325, 42, + 327, 42, + 329, 42, + 330, 42, + 331, 42, + 332, 42, + 333, 42, + 334, 42, + 335, 42, + 336, 42, + 337, 42, + 339, 42, + 341, 42, + 344, 42, + 347, 42, + 349, 42, + 352, 42, + 354, 42, + 356, 42, + 358, 42, + 359, 42, + 360, 42, + 361, 42, + 362, 42, + 363, 42, + 365, 42, + 367, 42, + -2, 0, +-1, 97, + 264, 42, + 268, 42, + 269, 42, + 281, 42, + 288, 42, + 289, 42, + 293, 42, + 294, 42, + 296, 42, + 298, 42, + 300, 42, + 302, 42, + 304, 42, + 306, 42, + 308, 42, + 311, 42, + 312, 42, + 313, 42, + 314, 42, + 315, 42, + 316, 42, + 317, 42, + 318, 42, + 319, 42, + 320, 42, + 321, 42, + 322, 42, + 323, 42, + 325, 42, + 327, 42, + 329, 42, + 330, 42, + 331, 42, + 332, 42, + 333, 42, + 334, 42, + 335, 42, + 336, 42, + 337, 42, + 339, 42, + 341, 42, + 344, 42, + 347, 42, + 349, 42, + 352, 42, + 354, 42, + 356, 42, + 358, 42, + 359, 42, + 360, 42, + 361, 42, + 362, 42, + 363, 42, + 365, 42, + 367, 42, + -2, 0, +-1, 111, + 270, 40, + 363, 42, + -2, 0, +-1, 117, + 270, 40, + 363, 42, + -2, 0, +-1, 182, + 360, 42, + 365, 42, + -2, 0, +-1, 183, + 360, 42, + -2, 0, +-1, 184, + 358, 42, + 360, 42, + -2, 0, +-1, 311, + 358, 42, + 360, 42, + 365, 42, + -2, 0, +-1, 313, + 363, 42, + 367, 42, + -2, 0, +-1, 335, + 360, 42, + 367, 42, + -2, 0, + }; +# define YYNPROD 203 +# define YYLAST 728 +int yyact[]={ + + 38, 84, 91, 92, 93, 94, 312, 86, 185, 99, + 83, 118, 335, 359, 341, 102, 95, 358, 98, 334, + 311, 311, 355, 85, 51, 329, 314, 20, 103, 96, + 118, 97, 313, 228, 101, 100, 56, 346, 118, 90, + 118, 59, 117, 62, 360, 58, 108, 70, 336, 64, + 311, 57, 228, 55, 60, 326, 184, 228, 310, 119, + 311, 107, 106, 182, 345, 183, 324, 232, 65, 110, + 67, 168, 69, 169, 352, 214, 118, 350, 328, 177, + 41, 356, 71, 174, 50, 175, 73, 61, 325, 52, + 53, 320, 54, 316, 63, 66, 176, 68, 327, 72, + 118, 87, 332, 118, 333, 331, 319, 361, 89, 116, + 88, 305, 38, 84, 91, 92, 93, 94, 118, 86, + 181, 99, 83, 353, 317, 231, 3, 102, 95, 218, + 98, 318, 105, 118, 19, 85, 51, 315, 118, 28, + 103, 96, 29, 97, 217, 321, 101, 100, 56, 309, + 170, 90, 172, 59, 173, 62, 171, 58, 118, 70, + 30, 64, 18, 57, 118, 55, 60, 44, 180, 37, + 179, 178, 113, 24, 104, 114, 25, 330, 351, 306, + 65, 212, 67, 115, 69, 82, 2, 81, 80, 27, + 17, 36, 23, 79, 71, 78, 50, 77, 73, 61, + 76, 52, 53, 75, 54, 74, 63, 66, 49, 68, + 47, 72, 42, 87, 38, 84, 91, 92, 93, 94, + 89, 86, 88, 99, 83, 40, 112, 322, 109, 102, + 95, 34, 98, 273, 274, 111, 33, 85, 51, 12, + 233, 32, 103, 96, 21, 97, 22, 26, 101, 100, + 56, 10, 9, 90, 8, 59, 7, 62, 31, 58, + 6, 70, 5, 64, 1, 57, 0, 55, 60, 13, + 0, 216, 15, 14, 0, 210, 0, 0, 16, 11, + 0, 0, 65, 0, 67, 234, 69, 236, 239, 221, + 222, 223, 224, 225, 226, 227, 71, 230, 50, 229, + 73, 61, 0, 52, 53, 237, 54, 0, 63, 66, + 0, 68, 0, 72, 0, 87, 46, 84, 91, 92, + 93, 94, 89, 86, 88, 99, 83, 45, 0, 0, + 0, 102, 95, 0, 98, 0, 289, 290, 0, 85, + 51, 0, 0, 235, 103, 96, 0, 97, 0, 238, + 101, 100, 56, 0, 0, 90, 0, 59, 0, 62, + 0, 58, 4, 70, 303, 64, 308, 57, 0, 55, + 60, 0, 0, 13, 304, 0, 15, 14, 0, 0, + 0, 0, 16, 11, 65, 0, 67, 0, 69, 338, + 0, 213, 0, 0, 0, 0, 0, 0, 71, 43, + 50, 0, 73, 61, 0, 52, 53, 323, 54, 347, + 63, 66, 35, 68, 152, 72, 0, 87, 0, 133, + 0, 150, 0, 130, 89, 131, 88, 128, 0, 127, + 0, 129, 0, 126, 362, 0, 132, 121, 120, 0, + 140, 123, 122, 0, 147, 164, 146, 0, 139, 158, + 135, 157, 143, 163, 136, 160, 138, 154, 137, 166, + 145, 162, 144, 161, 149, 156, 151, 155, 0, 134, + 0, 0, 124, 0, 125, 0, 153, 141, 211, 148, + 215, 142, 165, 39, 159, 0, 167, 0, 219, 220, + 0, 295, 296, 297, 298, 299, 0, 0, 291, 292, + 293, 294, 0, 35, 0, 0, 0, 339, 340, 35, + 342, 343, 344, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 348, 0, 0, 0, 48, 0, 0, 0, + 0, 0, 0, 354, 0, 0, 0, 0, 0, 0, + 0, 0, 357, 0, 0, 0, 0, 0, 0, 0, + 0, 354, 363, 364, 275, 276, 277, 278, 279, 280, + 281, 282, 283, 284, 285, 286, 287, 288, 0, 0, + 0, 0, 0, 0, 0, 307, 0, 186, 187, 188, + 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, + 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, + 209, 0, 0, 240, 241, 242, 243, 244, 245, 246, + 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, + 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, + 267, 268, 269, 270, 271, 272, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 337, 0, 215, 300, 301, 302, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 349 }; +int yypact[]={ + + -130, -1000, 100, -1000, -1000, -1000, -1000, -1000, -1000, -1000, + -1000, -95, -229, -1000, -84, -118, -97, -4, -1000, -1000, + -42, -125, -298, -1000, -1000, -1000, -299, -1000, -1000, -316, + -1000, -1000, -288, -103, -161, -321, -219, -279, -1000, -1000, + 125, -1000, 131, -275, -151, -214, -1000, -172, -1000, -301, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, -1000, -1000, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -42, -1000, -1000, -42, -42, -42, -42, + -128, -1000, -1000, -1000, -1000, -1000, -42, -42, -42, -42, + -42, -42, -42, -42, -303, -1000, -84, -118, -133, -290, + -125, -42, -125, -42, -1000, -1000, -1000, -42, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, -42, -256, -42, -108, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, + -219, -1000, -300, -1000, -361, -331, -339, -1000, -1000, -1000, + -1000, -131, -195, -157, -137, -162, -177, -219, -112, -1000, + -1000, -1000, -125, -292, -303, -182, -308, -265, -1000, -279, + -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -186, -1000, -275, -275, -275, -275, -275, + -275, -275, -275, -275, -275, -275, -275, -275, -275, -151, + -151, -214, -214, -214, -214, -1000, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -340, -257, -1000, -348, -1000, -310, -1000, + -1000, -42, -1000, -42, -1000, -42, -42, -352, -42, -42, + -42, -1000, -294, -327, -1000, -1000, -1000, -1000, 60, -1000, + -42, -1000, -1000, -1000, -1000, -42, -1000, -1000, -1000, -219, + -192, -144, -219, -219, -219, -1000, -343, -1000, -284, -1000, + -42, -350, -1000, -318, -255, -1000, -1000, -219, -1000, -144, + -42, -42, -1000, -219, -219 }; +int yypgo[]={ + + 0, 264, 186, 262, 260, 256, 254, 252, 251, 247, + 189, 246, 192, 244, 174, 241, 240, 239, 236, 235, + 231, 228, 227, 226, 191, 391, 169, 483, 225, 80, + 212, 399, 167, 327, 316, 210, 526, 208, 205, 203, + 200, 197, 195, 193, 188, 187, 185, 181, 75, 179, + 178, 74, 177 }; +int yyr1[]={ + + 0, 1, 2, 2, 3, 3, 3, 3, 3, 8, + 9, 9, 10, 10, 10, 7, 11, 11, 12, 12, + 13, 6, 15, 4, 16, 16, 5, 21, 17, 22, + 22, 22, 14, 14, 18, 18, 23, 23, 19, 19, + 20, 20, 25, 25, 24, 24, 26, 26, 27, 27, + 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, + 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, + 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, + 27, 28, 28, 28, 29, 29, 30, 30, 30, 30, + 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, + 30, 31, 31, 31, 32, 32, 32, 32, 32, 33, + 33, 33, 33, 33, 34, 34, 35, 35, 35, 35, + 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, + 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, + 36, 36, 36, 36, 36, 37, 37, 37, 37, 37, + 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + 37, 37, 37, 37, 37, 37, 37, 37, 43, 43, + 44, 44, 45, 45, 46, 40, 40, 40, 40, 41, + 41, 42, 50, 50, 51, 51, 47, 47, 49, 49, + 38, 38, 38, 38, 39, 52, 52, 52, 48, 48, + 1, 5, 24 }; +int yyr2[]={ + + 0, 5, 0, 4, 3, 3, 3, 3, 3, 5, + 2, 7, 3, 3, 7, 5, 2, 7, 3, 3, + 1, 7, 1, 13, 1, 3, 13, 1, 13, 1, + 3, 7, 3, 7, 1, 9, 3, 3, 1, 7, + 1, 7, 1, 2, 2, 7, 2, 7, 2, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 2, 7, 11, 2, 7, 2, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 2, 7, 7, 2, 7, 7, 7, 7, 2, + 7, 7, 7, 7, 2, 7, 2, 7, 7, 7, + 2, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 5, 3, 3, 5, 7, 7, + 7, 9, 7, 9, 9, 7, 5, 5, 5, 9, + 5, 9, 5, 9, 5, 3, 5, 5, 9, 9, + 13, 13, 2, 7, 7, 7, 3, 7, 3, 7, + 3, 3, 3, 3, 13, 3, 3, 3, 2, 7, + 6, 8, 2 }; +int yychk[]={ + + -1000, -1, -2, 256, 262, -3, -4, -5, -6, -7, + -8, 283, -17, 273, 277, 276, 282, -2, 257, 363, + 256, -13, -11, -12, 257, 260, -9, -10, 257, 260, + 257, 262, -15, -18, -20, -25, -24, -26, 256, -27, + -28, -29, -30, -31, -32, -33, -34, -35, -36, -37, + 340, 280, 345, 346, 348, 309, 292, 307, 301, 297, + 310, 343, 299, 350, 305, 324, 351, 326, 353, 328, + 303, 338, 355, 342, -38, -39, -40, -41, -42, -43, + -44, -45, -46, 266, 257, 279, 263, 357, 366, 364, + 295, 258, 259, 260, 261, 272, 285, 287, 274, 265, + 291, 290, 271, 284, -14, 257, 360, 360, 362, -21, + 357, -19, -23, 275, 278, 286, 270, 363, 295, 338, + 313, 312, 317, 316, 347, 349, 308, 304, 302, 306, + 298, 300, 311, 294, 344, 325, 329, 333, 331, 323, + 315, 352, 356, 327, 337, 335, 321, 319, 354, 339, + 296, 341, 289, 345, 326, 336, 334, 320, 318, 353, + 324, 332, 330, 322, 314, 351, 328, 355, 346, 348, + 301, 307, 303, 305, 297, 299, 310, 293, 343, 342, + 340, 292, 364, 366, 357, 309, -36, -36, -36, -36, + -36, -36, -36, -36, -36, -36, -36, -36, -36, -36, + -36, -36, -36, -36, -36, -36, -36, -36, -36, -36, + -24, -25, -47, -25, -48, -25, -47, 272, 257, -25, + -25, -24, -24, -24, -24, -24, -24, -24, 360, -12, + -10, 258, 357, -16, -14, -20, -14, -24, -20, -26, + -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, + -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, + -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, + -27, -27, -27, -29, -29, -31, -31, -31, -31, -31, + -31, -31, -31, -31, -31, -31, -31, -31, -31, -32, + -32, -33, -33, -33, -33, -34, -34, -34, -34, -34, + -36, -36, -36, -47, -24, 367, -49, -25, -47, 257, + 358, 360, 367, 363, 365, 268, 288, 281, 268, 268, + 268, 257, -22, -14, 358, 270, 363, 363, 264, 365, + -52, 362, 359, 361, 367, 360, 358, -25, -48, -24, + -24, 366, -24, -24, -24, 358, 364, -29, -24, -25, + 269, -50, -51, 267, -24, 365, 365, -24, 367, 363, + 362, 362, -51, -24, -24 }; +int yydef[]={ + + -2, -2, 0, 2, 1, 3, 4, 5, 6, 7, + 8, 0, 0, 20, 0, 0, 0, 0, 22, 34, + -2, 0, 15, 16, 18, 19, 9, 10, 12, 13, + 27, 200, 0, 38, 0, 0, 43, 44, 202, 46, + 48, 81, 84, 86, 101, 104, 109, 114, 116, 120, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 145, 146, 147, 148, 149, 150, + 151, 152, 153, 0, 155, 156, -2, -2, -2, -2, + 0, 190, 191, 192, 193, 175, -2, -2, 0, 0, + 0, 0, 0, 0, 21, 32, 0, 0, 0, 0, + 24, -2, 0, 0, 36, 37, 201, -2, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, -2, -2, -2, 0, 121, 122, 123, 124, + 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, + 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, + 154, 157, 0, 186, 0, 198, 0, 166, 167, 176, + 177, 43, 0, 0, 168, 170, 172, 174, 0, 17, + 11, 14, 29, 0, 25, 0, 0, 0, 41, 45, + 47, 49, 50, 51, 52, 53, 54, 55, 56, 57, + 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, + 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, + 78, 79, 80, 82, 85, 87, 88, 89, 90, 91, + 92, 93, 94, 95, 96, 97, 98, 99, 100, 102, + 103, 105, 106, 107, 108, 110, 111, 112, 113, 115, + 117, 118, 119, 0, 43, 162, 0, 188, 0, 165, + 158, -2, 159, -2, 160, 0, 0, 0, 0, 0, + 0, 33, 0, 30, 23, 26, 35, 39, 0, 161, + 0, 195, 196, 197, 163, -2, 164, 187, 199, 178, + 179, 0, 169, 171, 173, 28, 0, 83, 0, 189, + 0, 0, 182, 0, 0, 31, 194, 180, 181, 0, + 0, 0, 183, 184, 185 }; +typedef struct { char *t_name; int t_val; } yytoktype; +#ifndef YYDEBUG +# define YYDEBUG 0 /* don't allow debugging */ +#endif + +#if YYDEBUG + +yytoktype yytoks[] = +{ + "IDENT", 257, + "INTLIT", 258, + "REALLIT", 259, + "STRINGLIT", 260, + "CSETLIT", 261, + "EOFX", 262, + "BREAK", 263, + "BY", 264, + "CASE", 265, + "CREATE", 266, + "DEFAULT", 267, + "DO", 268, + "ELSE", 269, + "END", 270, + "EVERY", 271, + "FAIL", 272, + "GLOBAL", 273, + "IF", 274, + "INITIAL", 275, + "INVOCABLE", 276, + "LINK", 277, + "LOCAL", 278, + "NEXT", 279, + "NOT", 280, + "OF", 281, + "PROCEDURE", 282, + "RECORD", 283, + "REPEAT", 284, + "RETURN", 285, + "STATIC", 286, + "SUSPEND", 287, + "THEN", 288, + "TO", 289, + "UNTIL", 290, + "WHILE", 291, + "BANG", 292, + "MOD", 293, + "AUGMOD", 294, + "AND", 295, + "AUGAND", 296, + "STAR", 297, + "AUGSTAR", 298, + "INTER", 299, + "AUGINTER", 300, + "PLUS", 301, + "AUGPLUS", 302, + "UNION", 303, + "AUGUNION", 304, + "MINUS", 305, + "AUGMINUS", 306, + "DIFF", 307, + "AUGDIFF", 308, + "DOT", 309, + "SLASH", 310, + "AUGSLASH", 311, + "ASSIGN", 312, + "SWAP", 313, + "NMLT", 314, + "AUGNMLT", 315, + "REVASSIGN", 316, + "REVSWAP", 317, + "SLT", 318, + "AUGSLT", 319, + "SLE", 320, + "AUGSLE", 321, + "NMLE", 322, + "AUGNMLE", 323, + "NMEQ", 324, + "AUGNMEQ", 325, + "SEQ", 326, + "AUGSEQ", 327, + "EQUIV", 328, + "AUGEQUIV", 329, + "NMGT", 330, + "AUGNMGT", 331, + "NMGE", 332, + "AUGNMGE", 333, + "SGT", 334, + "AUGSGT", 335, + "SGE", 336, + "AUGSGE", 337, + "QMARK", 338, + "AUGQMARK", 339, + "AT", 340, + "AUGAT", 341, + "BACKSLASH", 342, + "CARET", 343, + "AUGCARET", 344, + "BAR", 345, + "CONCAT", 346, + "AUGCONCAT", 347, + "LCONCAT", 348, + "AUGLCONCAT", 349, + "TILDE", 350, + "NMNE", 351, + "AUGNMNE", 352, + "SNE", 353, + "AUGSNE", 354, + "NEQUIV", 355, + "AUGNEQUIV", 356, + "LPAREN", 357, + "RPAREN", 358, + "PCOLON", 359, + "COMMA", 360, + "MCOLON", 361, + "COLON", 362, + "SEMICOL", 363, + "LBRACK", 364, + "RBRACK", 365, + "LBRACE", 366, + "RBRACE", 367, + "-unknown-", -1 /* ends search */ +}; + +char * yyreds[] = +{ + "-no such reduction-", + "program : decls EOFX", + "decls : /* empty */", + "decls : decls decl", + "decl : record", + "decl : proc", + "decl : global", + "decl : link", + "decl : invocable", + "invocable : INVOCABLE invoclist", + "invoclist : invocop", + "invoclist : invoclist COMMA invocop", + "invocop : IDENT", + "invocop : STRINGLIT", + "invocop : STRINGLIT COLON INTLIT", + "link : LINK lnklist", + "lnklist : lnkfile", + "lnklist : lnklist COMMA lnkfile", + "lnkfile : IDENT", + "lnkfile : STRINGLIT", + "global : GLOBAL", + "global : GLOBAL idlist", + "record : RECORD IDENT", + "record : RECORD IDENT LPAREN fldlist RPAREN", + "fldlist : /* empty */", + "fldlist : idlist", + "proc : prochead SEMICOL locals initial procbody END", + "prochead : PROCEDURE IDENT", + "prochead : PROCEDURE IDENT LPAREN arglist RPAREN", + "arglist : /* empty */", + "arglist : idlist", + "arglist : idlist LBRACK RBRACK", + "idlist : IDENT", + "idlist : idlist COMMA IDENT", + "locals : /* empty */", + "locals : locals retention idlist SEMICOL", + "retention : LOCAL", + "retention : STATIC", + "initial : /* empty */", + "initial : INITIAL expr SEMICOL", + "procbody : /* empty */", + "procbody : nexpr SEMICOL procbody", + "nexpr : /* empty */", + "nexpr : expr", + "expr : expr1a", + "expr : expr AND expr1a", + "expr1a : expr1", + "expr1a : expr1a QMARK expr1", + "expr1 : expr2", + "expr1 : expr2 SWAP expr1", + "expr1 : expr2 ASSIGN expr1", + "expr1 : expr2 REVSWAP expr1", + "expr1 : expr2 REVASSIGN expr1", + "expr1 : expr2 AUGCONCAT expr1", + "expr1 : expr2 AUGLCONCAT expr1", + "expr1 : expr2 AUGDIFF expr1", + "expr1 : expr2 AUGUNION expr1", + "expr1 : expr2 AUGPLUS expr1", + "expr1 : expr2 AUGMINUS expr1", + "expr1 : expr2 AUGSTAR expr1", + "expr1 : expr2 AUGINTER expr1", + "expr1 : expr2 AUGSLASH expr1", + "expr1 : expr2 AUGMOD expr1", + "expr1 : expr2 AUGCARET expr1", + "expr1 : expr2 AUGNMEQ expr1", + "expr1 : expr2 AUGEQUIV expr1", + "expr1 : expr2 AUGNMGE expr1", + "expr1 : expr2 AUGNMGT expr1", + "expr1 : expr2 AUGNMLE expr1", + "expr1 : expr2 AUGNMLT expr1", + "expr1 : expr2 AUGNMNE expr1", + "expr1 : expr2 AUGNEQUIV expr1", + "expr1 : expr2 AUGSEQ expr1", + "expr1 : expr2 AUGSGE expr1", + "expr1 : expr2 AUGSGT expr1", + "expr1 : expr2 AUGSLE expr1", + "expr1 : expr2 AUGSLT expr1", + "expr1 : expr2 AUGSNE expr1", + "expr1 : expr2 AUGQMARK expr1", + "expr1 : expr2 AUGAND expr1", + "expr1 : expr2 AUGAT expr1", + "expr2 : expr3", + "expr2 : expr2 TO expr3", + "expr2 : expr2 TO expr3 BY expr3", + "expr3 : expr4", + "expr3 : expr4 BAR expr3", + "expr4 : expr5", + "expr4 : expr4 SEQ expr5", + "expr4 : expr4 SGE expr5", + "expr4 : expr4 SGT expr5", + "expr4 : expr4 SLE expr5", + "expr4 : expr4 SLT expr5", + "expr4 : expr4 SNE expr5", + "expr4 : expr4 NMEQ expr5", + "expr4 : expr4 NMGE expr5", + "expr4 : expr4 NMGT expr5", + "expr4 : expr4 NMLE expr5", + "expr4 : expr4 NMLT expr5", + "expr4 : expr4 NMNE expr5", + "expr4 : expr4 EQUIV expr5", + "expr4 : expr4 NEQUIV expr5", + "expr5 : expr6", + "expr5 : expr5 CONCAT expr6", + "expr5 : expr5 LCONCAT expr6", + "expr6 : expr7", + "expr6 : expr6 PLUS expr7", + "expr6 : expr6 DIFF expr7", + "expr6 : expr6 UNION expr7", + "expr6 : expr6 MINUS expr7", + "expr7 : expr8", + "expr7 : expr7 STAR expr8", + "expr7 : expr7 INTER expr8", + "expr7 : expr7 SLASH expr8", + "expr7 : expr7 MOD expr8", + "expr8 : expr9", + "expr8 : expr9 CARET expr8", + "expr9 : expr10", + "expr9 : expr9 BACKSLASH expr10", + "expr9 : expr9 AT expr10", + "expr9 : expr9 BANG expr10", + "expr10 : expr11", + "expr10 : AT expr10", + "expr10 : NOT expr10", + "expr10 : BAR expr10", + "expr10 : CONCAT expr10", + "expr10 : LCONCAT expr10", + "expr10 : DOT expr10", + "expr10 : BANG expr10", + "expr10 : DIFF expr10", + "expr10 : PLUS expr10", + "expr10 : STAR expr10", + "expr10 : SLASH expr10", + "expr10 : CARET expr10", + "expr10 : INTER expr10", + "expr10 : TILDE expr10", + "expr10 : MINUS expr10", + "expr10 : NMEQ expr10", + "expr10 : NMNE expr10", + "expr10 : SEQ expr10", + "expr10 : SNE expr10", + "expr10 : EQUIV expr10", + "expr10 : UNION expr10", + "expr10 : QMARK expr10", + "expr10 : NEQUIV expr10", + "expr10 : BACKSLASH expr10", + "expr11 : literal", + "expr11 : section", + "expr11 : return", + "expr11 : if", + "expr11 : case", + "expr11 : while", + "expr11 : until", + "expr11 : every", + "expr11 : repeat", + "expr11 : CREATE expr", + "expr11 : IDENT", + "expr11 : NEXT", + "expr11 : BREAK nexpr", + "expr11 : LPAREN exprlist RPAREN", + "expr11 : LBRACE compound RBRACE", + "expr11 : LBRACK exprlist RBRACK", + "expr11 : expr11 LBRACK exprlist RBRACK", + "expr11 : expr11 LBRACE RBRACE", + "expr11 : expr11 LBRACE pdcolist RBRACE", + "expr11 : expr11 LPAREN exprlist RPAREN", + "expr11 : expr11 DOT IDENT", + "expr11 : AND FAIL", + "expr11 : AND IDENT", + "while : WHILE expr", + "while : WHILE expr DO expr", + "until : UNTIL expr", + "until : UNTIL expr DO expr", + "every : EVERY expr", + "every : EVERY expr DO expr", + "repeat : REPEAT expr", + "return : FAIL", + "return : RETURN nexpr", + "return : SUSPEND nexpr", + "return : SUSPEND expr DO expr", + "if : IF expr THEN expr", + "if : IF expr THEN expr ELSE expr", + "case : CASE expr OF LBRACE caselist RBRACE", + "caselist : cclause", + "caselist : caselist SEMICOL cclause", + "cclause : DEFAULT COLON expr", + "cclause : expr COLON expr", + "exprlist : nexpr", + "exprlist : exprlist COMMA nexpr", + "pdcolist : nexpr", + "pdcolist : pdcolist COMMA nexpr", + "literal : INTLIT", + "literal : REALLIT", + "literal : STRINGLIT", + "literal : CSETLIT", + "section : expr11 LBRACK expr sectop expr RBRACK", + "sectop : COLON", + "sectop : PCOLON", + "sectop : MCOLON", + "compound : nexpr", + "compound : nexpr SEMICOL compound", + "program : error decls EOFX", + "proc : prochead error procbody END", + "expr : error", +}; +#endif +#line 1 "/usr/lib/yaccpar" +/* @(#)yaccpar 1.10 89/04/04 SMI; from S5R3 1.10 */ + +/* +** Skeleton parser driver for yacc output +*/ + +/* +** yacc user known macros and defines +*/ +#define YYERROR goto yyerrlab +#define YYACCEPT { free(yys); free(yyv); return(0); } +#define YYABORT { free(yys); free(yyv); return(1); } +#define YYBACKUP( newtoken, newvalue )\ +{\ + if ( yychar >= 0 || ( yyr2[ yytmp ] >> 1 ) != 1 )\ + {\ + tsyserr("parser: syntax error - cannot backup" );\ + goto yyerrlab;\ + }\ + yychar = newtoken;\ + yystate = *yyps;\ + yylval = newvalue;\ + goto yynewstate;\ +} +#define YYRECOVERING() (!!yyerrflag) +#ifndef YYDEBUG +# define YYDEBUG 1 /* make debugging available */ +#endif + +/* +** user known globals +*/ +int yydebug; /* set to 1 to get debugging */ + +/* +** driver internal defines +*/ +#define YYFLAG (-1000) + +/* +** static variables used by the parser +*/ +static YYSTYPE *yyv; /* value stack */ +static int *yys; /* state stack */ + +static YYSTYPE *yypv; /* top of value stack */ +static int *yyps; /* top of state stack */ + +static int yystate; /* current state */ +static int yytmp; /* extra var (lasts between blocks) */ + +int yynerrs; /* number of errors */ + +int yyerrflag; /* error recovery flag */ +int yychar; /* current input token number */ + + +/* +** yyparse - return 0 if worked, 1 if syntax error not recovered from +*/ +int +yyparse() +{ + register YYSTYPE *yypvt; /* top of value stack for $vars */ + unsigned yymaxdepth = YYMAXDEPTH; + + /* + ** Initialize externals - yyparse may be called more than once + */ + yyv = (YYSTYPE*)malloc(yymaxdepth*sizeof(YYSTYPE)); + yys = (int*)malloc(yymaxdepth*sizeof(int)); + if (!yyv || !yys) + { + tsyserr("parser: out of memory" ); + return(1); + } + yypv = &yyv[-1]; + yyps = &yys[-1]; + yystate = 0; + yytmp = 0; + yynerrs = 0; + yyerrflag = 0; + yychar = -1; + + goto yystack; + { + register YYSTYPE *yy_pv; /* top of value stack */ + register int *yy_ps; /* top of state stack */ + register int yy_state; /* current state */ + register int yy_n; /* internal state number info */ + + /* + ** get globals into registers. + ** branch to here only if YYBACKUP was called. + */ + yynewstate: + yy_pv = yypv; + yy_ps = yyps; + yy_state = yystate; + goto yy_newstate; + + /* + ** get globals into registers. + ** either we just started, or we just finished a reduction + */ + yystack: + yy_pv = yypv; + yy_ps = yyps; + yy_state = yystate; + + /* + ** top of for (;;) loop while no reductions done + */ + yy_stack: + /* + ** put a state and value onto the stacks + */ +#if YYDEBUG + /* + ** if debugging, look up token value in list of value vs. + ** name pairs. 0 and negative (-1) are special values. + ** Note: linear search is used since time is not a real + ** consideration while debugging. + */ + if ( yydebug ) + { + register int yy_i; + + (void)printf( "State %d, token ", yy_state ); + if ( yychar == 0 ) + (void)printf( "end-of-file\n" ); + else if ( yychar < 0 ) + (void)printf( "-none-\n" ); + else + { + for ( yy_i = 0; yytoks[yy_i].t_val >= 0; + yy_i++ ) + { + if ( yytoks[yy_i].t_val == yychar ) + break; + } + (void)printf( "%s\n", yytoks[yy_i].t_name ); + } + } +#endif + if ( ++yy_ps >= &yys[ yymaxdepth ] ) /* room on stack? */ + { + /* + ** reallocate and recover. Note that pointers + ** have to be reset, or bad things will happen + */ + int yyps_index = (yy_ps - yys); + int yypv_index = (yy_pv - yyv); + int yypvt_index = (yypvt - yyv); + yymaxdepth += YYMAXDEPTH; + yyv = (YYSTYPE*)realloc((char*)yyv, + yymaxdepth * sizeof(YYSTYPE)); + yys = (int*)realloc((char*)yys, + yymaxdepth * sizeof(int)); + if (!yyv || !yys) + { + tsyserr("parse stack overflow" ); + return(1); + } + yy_ps = yys + yyps_index; + yy_pv = yyv + yypv_index; + yypvt = yyv + yypvt_index; + } + *yy_ps = yy_state; + *++yy_pv = yyval; + + /* + ** we have a new state - find out what to do + */ + yy_newstate: + if ( ( yy_n = yypact[ yy_state ] ) <= YYFLAG ) + goto yydefault; /* simple state */ +#if YYDEBUG + /* + ** if debugging, need to mark whether new token grabbed + */ + yytmp = yychar < 0; +#endif + if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) ) + yychar = 0; /* reached EOF */ +#if YYDEBUG + if ( yydebug && yytmp ) + { + register int yy_i; + + (void)printf( "Received token " ); + if ( yychar == 0 ) + (void)printf( "end-of-file\n" ); + else if ( yychar < 0 ) + (void)printf( "-none-\n" ); + else + { + for ( yy_i = 0; yytoks[yy_i].t_val >= 0; + yy_i++ ) + { + if ( yytoks[yy_i].t_val == yychar ) + break; + } + (void)printf( "%s\n", yytoks[yy_i].t_name ); + } + } +#endif + if ( ( ( yy_n += yychar ) < 0 ) || ( yy_n >= YYLAST ) ) + goto yydefault; + if ( yychk[ yy_n = yyact[ yy_n ] ] == yychar ) /*valid shift*/ + { + yychar = -1; + yyval = yylval; + yy_state = yy_n; + if ( yyerrflag > 0 ) + yyerrflag--; + goto yy_stack; + } + + yydefault: + if ( ( yy_n = yydef[ yy_state ] ) == -2 ) + { +#if YYDEBUG + yytmp = yychar < 0; +#endif + if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) ) + yychar = 0; /* reached EOF */ +#if YYDEBUG + if ( yydebug && yytmp ) + { + register int yy_i; + + (void)printf( "Received token " ); + if ( yychar == 0 ) + (void)printf( "end-of-file\n" ); + else if ( yychar < 0 ) + (void)printf( "-none-\n" ); + else + { + for ( yy_i = 0; + yytoks[yy_i].t_val >= 0; + yy_i++ ) + { + if ( yytoks[yy_i].t_val + == yychar ) + { + break; + } + } + (void)printf( "%s\n", yytoks[yy_i].t_name ); + } + } +#endif + /* + ** look through exception table + */ + { + register int *yyxi = yyexca; + + while ( ( *yyxi != -1 ) || + ( yyxi[1] != yy_state ) ) + { + yyxi += 2; + } + while ( ( *(yyxi += 2) >= 0 ) && + ( *yyxi != yychar ) ) + ; + if ( ( yy_n = yyxi[1] ) < 0 ) + YYACCEPT; + } + } + + /* + ** check for syntax error + */ + if ( yy_n == 0 ) /* have an error */ + { + /* no worry about speed here! */ + switch ( yyerrflag ) + { + case 0: /* new error */ + yyerror(yychar, yylval, yy_state ); + goto skip_init; + yyerrlab: + /* + ** get globals into registers. + ** we have a user generated syntax type error + */ + yy_pv = yypv; + yy_ps = yyps; + yy_state = yystate; + yynerrs++; + skip_init: + case 1: + case 2: /* incompletely recovered error */ + /* try again... */ + yyerrflag = 3; + /* + ** find state where "error" is a legal + ** shift action + */ + while ( yy_ps >= yys ) + { + yy_n = yypact[ *yy_ps ] + YYERRCODE; + if ( yy_n >= 0 && yy_n < YYLAST && + yychk[yyact[yy_n]] == YYERRCODE) { + /* + ** simulate shift of "error" + */ + yy_state = yyact[ yy_n ]; + goto yy_stack; + } + /* + ** current state has no shift on + ** "error", pop stack + */ +#if YYDEBUG +# define _POP_ "Error recovery pops state %d, uncovers state %d\n" + if ( yydebug ) + (void)printf( _POP_, *yy_ps, + yy_ps[-1] ); +# undef _POP_ +#endif + yy_ps--; + yy_pv--; + } + /* + ** there is no state on stack with "error" as + ** a valid shift. give up. + */ + YYABORT; + case 3: /* no shift yet; eat a token */ +#if YYDEBUG + /* + ** if debugging, look up token in list of + ** pairs. 0 and negative shouldn't occur, + ** but since timing doesn't matter when + ** debugging, it doesn't hurt to leave the + ** tests here. + */ + if ( yydebug ) + { + register int yy_i; + + (void)printf( "Error recovery discards " ); + if ( yychar == 0 ) + (void)printf( "token end-of-file\n" ); + else if ( yychar < 0 ) + (void)printf( "token -none-\n" ); + else + { + for ( yy_i = 0; + yytoks[yy_i].t_val >= 0; + yy_i++ ) + { + if ( yytoks[yy_i].t_val + == yychar ) + { + break; + } + } + (void)printf( "token %s\n", + yytoks[yy_i].t_name ); + } + } +#endif + if ( yychar == 0 ) /* reached EOF. quit */ + YYABORT; + yychar = -1; + goto yy_newstate; + } + }/* end if ( yy_n == 0 ) */ + /* + ** reduction by production yy_n + ** put stack tops, etc. so things right after switch + */ +#if YYDEBUG + /* + ** if debugging, print the string that is the user's + ** specification of the reduction which is just about + ** to be done. + */ + if ( yydebug ) + (void)printf( "Reduce by (%d) \"%s\"\n", + yy_n, yyreds[ yy_n ] ); +#endif + yytmp = yy_n; /* value to switch over */ + yypvt = yy_pv; /* $vars top of value stack */ + /* + ** Look in goto table for next state + ** Sorry about using yy_state here as temporary + ** register variable, but why not, if it works... + ** If yyr2[ yy_n ] doesn't have the low order bit + ** set, then there is no action to be done for + ** this reduction. So, no saving & unsaving of + ** registers done. The only difference between the + ** code just after the if and the body of the if is + ** the goto yy_stack in the body. This way the test + ** can be made before the choice of what to do is needed. + */ + { + /* length of production doubled with extra bit */ + register int yy_len = yyr2[ yy_n ]; + + if ( !( yy_len & 01 ) ) + { + yy_len >>= 1; + yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */ + yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] + + *( yy_ps -= yy_len ) + 1; + if ( yy_state >= YYLAST || + yychk[ yy_state = + yyact[ yy_state ] ] != -yy_n ) + { + yy_state = yyact[ yypgo[ yy_n ] ]; + } + goto yy_stack; + } + yy_len >>= 1; + yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */ + yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] + + *( yy_ps -= yy_len ) + 1; + if ( yy_state >= YYLAST || + yychk[ yy_state = yyact[ yy_state ] ] != -yy_n ) + { + yy_state = yyact[ yypgo[ yy_n ] ]; + } + } + /* save until reenter driver code */ + yystate = yy_state; + yyps = yy_ps; + yypv = yy_pv; + } + /* + ** code supplied by user is placed in this switch + */ + switch( yytmp ) + { + +case 1: +# line 177 "cgram.g" +{;} break; +case 4: +# line 182 "cgram.g" +{;} break; +case 5: +# line 183 "cgram.g" +{proc_lst->tree = yypvt[-0] ;} break; +case 6: +# line 184 "cgram.g" +{;} break; +case 7: +# line 185 "cgram.g" +{;} break; +case 8: +# line 186 "cgram.g" +{;} break; +case 9: +# line 188 "cgram.g" +{;} break; +case 11: +# line 191 "cgram.g" +{;} break; +case 12: +# line 193 "cgram.g" +{invoc_grp(Str0(yypvt[-0])); ;} break; +case 13: +# line 194 "cgram.g" +{invocbl(yypvt[-0], -1); ;} break; +case 14: +# line 195 "cgram.g" +{invocbl(yypvt[-2], atoi(Str0(yypvt[-0]))); ;} break; +case 15: +# line 197 "cgram.g" +{;} break; +case 17: +# line 200 "cgram.g" +{;} break; +case 18: +# line 202 "cgram.g" +{lnkdcl(Str0(yypvt[-0])); ;} break; +case 19: +# line 203 "cgram.g" +{lnkdcl(Str0(yypvt[-0])); ;} break; +case 20: +# line 205 "cgram.g" +{idflag = F_Global ;} break; +case 21: +# line 205 "cgram.g" +{;} break; +case 22: +# line 207 "cgram.g" +{init_rec(Str0(yypvt[-0])); idflag = F_Field ;} break; +case 23: +# line 207 "cgram.g" +{ + ; + } break; +case 24: +# line 211 "cgram.g" +{;} break; +case 25: +# line 212 "cgram.g" +{;} break; +case 26: +# line 214 "cgram.g" +{ + yyval = tree6(N_Proc,yypvt[-5],yypvt[-5],yypvt[-2],yypvt[-1],yypvt[-0]) ; + } break; +case 27: +# line 218 "cgram.g" +{init_proc(Str0(yypvt[-0])); idflag = F_Argument ;} break; +case 28: +# line 218 "cgram.g" +{ + ; + } break; +case 29: +# line 222 "cgram.g" +{;} break; +case 30: +# line 223 "cgram.g" +{;} break; +case 31: +# line 224 "cgram.g" +{proc_lst->nargs = -proc_lst->nargs ;} break; +case 32: +# line 227 "cgram.g" +{ + install(Str0(yypvt[-0]),idflag) ; + } break; +case 33: +# line 230 "cgram.g" +{ + install(Str0(yypvt[-0]),idflag) ; + } break; +case 34: +# line 234 "cgram.g" +{;} break; +case 35: +# line 235 "cgram.g" +{;} break; +case 36: +# line 237 "cgram.g" +{idflag = F_Dynamic ;} break; +case 37: +# line 238 "cgram.g" +{idflag = F_Static ;} break; +case 38: +# line 240 "cgram.g" +{yyval = tree1(N_Empty) ;} break; +case 39: +# line 241 "cgram.g" +{yyval = yypvt[-1] ;} break; +case 40: +# line 243 "cgram.g" +{yyval = tree1(N_Empty) ;} break; +case 41: +# line 244 "cgram.g" +{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 42: +# line 246 "cgram.g" +{yyval = tree1(N_Empty) ;} break; +case 45: +# line 250 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 47: +# line 253 "cgram.g" +{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 49: +# line 256 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 50: +# line 257 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 51: +# line 258 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 52: +# line 259 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 53: +# line 260 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 54: +# line 261 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 55: +# line 262 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 56: +# line 263 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 57: +# line 264 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 58: +# line 265 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 59: +# line 266 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 60: +# line 267 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 61: +# line 268 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 62: +# line 269 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 63: +# line 270 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 64: +# line 271 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 65: +# line 272 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 66: +# line 273 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 67: +# line 274 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 68: +# line 275 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 69: +# line 276 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 70: +# line 277 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 71: +# line 278 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 72: +# line 279 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 73: +# line 280 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 74: +# line 281 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 75: +# line 282 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 76: +# line 283 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 77: +# line 284 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 78: +# line 285 "cgram.g" +{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 79: +# line 286 "cgram.g" +{yyval = aug_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 80: +# line 287 "cgram.g" +{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 82: +# line 290 "cgram.g" +{yyval = to_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 83: +# line 291 "cgram.g" +{yyval = toby_nd(yypvt[-3],yypvt[-4],yypvt[-2],yypvt[-0]) ;} break; +case 85: +# line 294 "cgram.g" +{yyval = tree4(N_Alt,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 87: +# line 297 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 88: +# line 298 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 89: +# line 299 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 90: +# line 300 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 91: +# line 301 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 92: +# line 302 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 93: +# line 303 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 94: +# line 304 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 95: +# line 305 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 96: +# line 306 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 97: +# line 307 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 98: +# line 308 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 99: +# line 309 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 100: +# line 310 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 102: +# line 313 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 103: +# line 314 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 105: +# line 317 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 106: +# line 318 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 107: +# line 319 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 108: +# line 320 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 110: +# line 323 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 111: +# line 324 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 112: +# line 325 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 113: +# line 326 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 115: +# line 329 "cgram.g" +{yyval = binary_nd(yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 117: +# line 332 "cgram.g" +{yyval = tree4(N_Limit,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 118: +# line 333 "cgram.g" +{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 119: +# line 334 "cgram.g" +{yyval = tree4(N_Apply,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 121: +# line 337 "cgram.g" +{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],tree1(N_Empty) ,yypvt[-0]) ;} break; +case 122: +# line 338 "cgram.g" +{yyval = tree3(N_Not,yypvt[-0],yypvt[-0]) ;} break; +case 123: +# line 339 "cgram.g" +{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break; +case 124: +# line 340 "cgram.g" +{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break; +case 125: +# line 341 "cgram.g" +{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]) ;} break; +case 126: +# line 342 "cgram.g" +{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; +case 127: +# line 343 "cgram.g" +{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; +case 128: +# line 344 "cgram.g" +{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; +case 129: +# line 345 "cgram.g" +{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; +case 130: +# line 346 "cgram.g" +{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; +case 131: +# line 347 "cgram.g" +{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; +case 132: +# line 348 "cgram.g" +{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; +case 133: +# line 349 "cgram.g" +{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; +case 134: +# line 350 "cgram.g" +{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; +case 135: +# line 351 "cgram.g" +{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; +case 136: +# line 352 "cgram.g" +{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; +case 137: +# line 353 "cgram.g" +{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; +case 138: +# line 354 "cgram.g" +{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; +case 139: +# line 355 "cgram.g" +{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; +case 140: +# line 356 "cgram.g" +{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; +case 141: +# line 357 "cgram.g" +{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; +case 142: +# line 358 "cgram.g" +{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; +case 143: +# line 359 "cgram.g" +{yyval = MultiUnary(yypvt[-1],yypvt[-0]) ;} break; +case 144: +# line 360 "cgram.g" +{yyval = unary_nd(yypvt[-1],yypvt[-0]) ;} break; +case 154: +# line 371 "cgram.g" +{yyval = tree3(N_Create,yypvt[-1],yypvt[-0]); proc_lst->has_coexpr = 1; ;} break; +case 155: +# line 372 "cgram.g" +{LSym0(yypvt[-0]) = putloc(Str0(yypvt[-0]),0) ;} break; +case 156: +# line 373 "cgram.g" +{yyval = tree2(N_Next,yypvt[-0]) ;} break; +case 157: +# line 374 "cgram.g" +{yyval = tree3(N_Break,yypvt[-1],yypvt[-0]) ;} break; +case 158: +# line 375 "cgram.g" +{if ((yypvt[-1])->n_type == N_Elist) yyval = invk_nd(yypvt[-2],tree1(N_Empty) ,yypvt[-1]); else yyval = yypvt[-1] ;} break; +case 159: +# line 376 "cgram.g" +{yyval = yypvt[-1] ;} break; +case 160: +# line 377 "cgram.g" +{yyval = list_nd(yypvt[-2],yypvt[-1]) ;} break; +case 161: +# line 378 "cgram.g" +{yyval = buildarray(yypvt[-3],yypvt[-2],yypvt[-1]) ;} break; +case 162: +# line 379 "cgram.g" +{yyval = invk_nd(yypvt[-1],yypvt[-2],list_nd(yypvt[-1],tree1(N_Empty) )) ;} break; +case 163: +# line 380 "cgram.g" +{yyval = invk_nd(yypvt[-2],yypvt[-3],list_nd(yypvt[-2],yypvt[-1])) ;} break; +case 164: +# line 381 "cgram.g" +{yyval = invk_nd(yypvt[-2],yypvt[-3],yypvt[-1]) ;} break; +case 165: +# line 382 "cgram.g" +{yyval = tree4(N_Field,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 166: +# line 383 "cgram.g" +{yyval = key_leaf(yypvt[-1],spec_str("fail")) ;} break; +case 167: +# line 384 "cgram.g" +{yyval = key_leaf(yypvt[-1],Str0(yypvt[-0])) ;} break; +case 168: +# line 386 "cgram.g" +{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; +case 169: +# line 387 "cgram.g" +{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; +case 170: +# line 389 "cgram.g" +{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; +case 171: +# line 390 "cgram.g" +{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; +case 172: +# line 392 "cgram.g" +{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; +case 173: +# line 393 "cgram.g" +{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; +case 174: +# line 395 "cgram.g" +{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; +case 175: +# line 397 "cgram.g" +{yyval = tree4(N_Ret,yypvt[-0],yypvt[-0],tree1(N_Empty) ) ;} break; +case 176: +# line 398 "cgram.g" +{yyval = tree4(N_Ret,yypvt[-1],yypvt[-1],yypvt[-0]) ;} break; +case 177: +# line 399 "cgram.g" +{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty) ) ;} break; +case 178: +# line 400 "cgram.g" +{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]) ;} break; +case 179: +# line 402 "cgram.g" +{yyval = tree5(N_If,yypvt[-3],yypvt[-2],yypvt[-0],tree1(N_Empty) ) ;} break; +case 180: +# line 403 "cgram.g" +{yyval = tree5(N_If,yypvt[-5],yypvt[-4],yypvt[-2],yypvt[-0]) ;} break; +case 181: +# line 405 "cgram.g" +{yyval = case_nd(yypvt[-5],yypvt[-4],yypvt[-1]) ;} break; +case 183: +# line 408 "cgram.g" +{yyval = tree4(N_Clist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 184: +# line 410 "cgram.g" +{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 185: +# line 411 "cgram.g" +{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; +case 186: +# line 413 "cgram.g" +{yyval = yypvt[-0]; ;} break; +case 187: +# line 414 "cgram.g" +{yyval = tree4(N_Elist,yypvt[-1],yypvt[-2],yypvt[-0]); ;} break; +case 188: +# line 416 "cgram.g" +{ + yyval = tree3(N_Create,yypvt[-0],yypvt[-0]); proc_lst->has_coexpr = 1; ; + } break; +case 189: +# line 419 "cgram.g" +{ + yyval =tree4(N_Elist,yypvt[-1],yypvt[-2],tree3(N_Create,yypvt[-1],yypvt[-0])); proc_lst->has_coexpr = 1; ; + } break; +case 190: +# line 423 "cgram.g" +{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_IntLit,0) ;} break; +case 191: +# line 424 "cgram.g" +{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_RealLit,0) ;} break; +case 192: +# line 425 "cgram.g" +{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_StrLit,(int)Val1(yypvt[-0])) ;} break; +case 193: +# line 426 "cgram.g" +{CSym0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_CsetLit,(int)Val1(yypvt[-0])) ;} break; +case 194: +# line 428 "cgram.g" +{yyval = sect_nd(yypvt[-2],yypvt[-5],yypvt[-3],yypvt[-1]) ;} break; +case 195: +# line 430 "cgram.g" +{yyval = yypvt[-0] ;} break; +case 196: +# line 431 "cgram.g" +{yyval = yypvt[-0] ;} break; +case 197: +# line 432 "cgram.g" +{yyval = yypvt[-0] ;} break; +case 199: +# line 435 "cgram.g" +{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]) ;} break; + } + goto yystack; /* reset registers in driver code */ +} diff --git a/src/iconc/cproto.h b/src/iconc/cproto.h new file mode 100644 index 0000000..a32b982 --- /dev/null +++ b/src/iconc/cproto.h @@ -0,0 +1,165 @@ +/* + * Prototypes for functions in iconc. + */ +struct sig_lst *add_sig (struct code *sig, struct c_fnc *fnc); +void addlib (char *libname); +struct code *alc_ary (int n); +int alc_cbufs (int num, nodeptr lifetime); +int alc_dtmp (nodeptr lifetime); +int alc_itmp (nodeptr lifetime); +struct code *alc_lbl (char *desc, int flag); +int alc_sbufs (int num, nodeptr lifetime); +#ifdef OptimizeType +unsigned int *alloc_mem_typ (unsigned int n_types); +#endif /* OptimizeType */ +void arth_anlz (struct il_code *var1, struct il_code *var2, + int *maybe_int, int *maybe_dbl, int *chk1, + struct code **conv1p, int *chk2, + struct code **conv2p); +struct node *aug_nd (nodeptr op, nodeptr arg1, nodeptr arg2); +struct node *binary_nd (nodeptr op, nodeptr arg1, nodeptr arg2); +void bitrange (int typcd, int *frst_bit, int *last_bit); +nodeptr buildarray (nodeptr a, nodeptr lb, nodeptr e); +void callc_add (struct c_fnc *cont); +void callo_add (char *oper_nm, int ret_flag, + struct c_fnc *cont, int need_cont, + struct code *arglist, struct code *on_ret); +struct node *case_nd (nodeptr loc_model, nodeptr expr, nodeptr cases); +int ccomp (char *srcname, char *exename); +void cd_add (struct code *cd); +struct val_loc *chk_alc (struct val_loc *rslt, nodeptr lifetime); +void chkinv (void); +void chkstrinv (void); +struct node *c_str_leaf (int type,struct node *loc_model, char *c); +void codegen (struct node *t); +int cond_anlz (struct il_code *il, struct code **cdp); +void const_blks (void); +struct val_loc *cvar_loc (char *name); +int do_inlin (struct implement *impl, nodeptr n, int *sep_cont, + struct op_symentry *symtab, int n_va); +void doiconx (char *s); +struct val_loc *dtmp_loc (int n); +void eval_arith (int indx1, int indx2, int *maybe_int, int *maybe_dbl); +int eval_cnv (int typcd, int indx, int def, int *cnv_flags); +int eval_is (int typcd,int indx); +void findcases (struct il_code *il, int has_dflt, + struct case_anlz *case_anlz); +void fix_fncs (struct c_fnc *fnc); +struct fentry *flookup (char *id); +void gen_inlin (struct il_code *il, struct val_loc *rslt, + struct code **scont_strt, + struct code **scont_fail, struct c_fnc *cont, + struct implement *impl, int nsyms, + struct op_symentry *symtab, nodeptr n, + int dcl_var, int n_va); +int getopr (int ac, int *cc); +#ifdef OptimizeType +unsigned int get_bit_vector (struct typinfo *src, int pos); +#endif /* OptimizeType */ +struct gentry *glookup (char *id); +void hsyserr (char **av, char *file); +struct node *i_str_leaf (int type,struct node *loc_model,char *c, int d); +long iconint (char *image); +struct code *il_copy (struct il_c *dest, struct val_loc *src); +struct code *il_cnv (int typcd, struct il_code *src, + struct il_c *dflt, struct il_c *dest); +struct code *il_dflt (int typcd, struct il_code *src, + struct il_c *dflt, struct il_c *dest); +void implproto (struct implement *ip); +void init (void); +void init_proc (char *name); +void init_rec (char *name); +void init_src (void); +void install (char *name,int flag); +struct gentry *instl_p (char *name, int flag); +struct node *int_leaf (int type,struct node *loc_model,int c); +struct val_loc *itmp_loc (int n); +struct node *invk_main (struct pentry *main_proc); +struct node *invk_nd (struct node *loc_model, struct node *proc, + struct node *args); +void invoc_grp (char *grp); +void invocbl (nodeptr op, int arity); +struct node *key_leaf (nodeptr loc_model, char *keyname); +void liveness (nodeptr n, nodeptr resumer, nodeptr *failer, int *gen); +struct node *list_nd (nodeptr loc_model, nodeptr args); +void lnkdcl (char *name); +void readdb (char *db_name); +struct val_loc *loc_cpy (struct val_loc *loc, int mod_access); +#ifdef OptimizeType +void mark_recs (struct fentry *fp, struct typinfo *typ, + int *num_offsets, int *offset, int *bad_recs); +#else /* OptimizeType */ +void mark_recs (struct fentry *fp, unsigned int *typ, + int *num_offsets, int *offset, int *bad_recs); +#endif /* OptimizeType */ +struct code *mk_goto (struct code *label); +struct node *multiunary (char *op, nodeptr loc_model, nodeptr oprnd); +struct sig_act *new_sgact (struct code *sig, struct code *cd, + struct sig_act *next); +int nextchar (void); +void nfatal (struct node *n, char *s1, char *s2); +int n_arg_sym (struct implement *ip); +void outerfnc (struct c_fnc *fnc); +int past_prms (struct node *n); +void proccode (struct pentry *proc); +void prt_fnc (struct c_fnc *fnc); +void prt_frame (char *prefix, int ntend, int n_itmp, + int i, int j, int k); +struct centry *putlit (char *image,int littype,int len); +struct lentry *putloc (char *id,int id_type); +void quit (char *msg); +void quitf (char *msg,char *arg); +void recconstr (struct rentry *r); +void resolve (struct pentry *proc); +unsigned int round2 (unsigned int n); +struct code *sig_cd (struct code *fail, struct c_fnc *fnc); +void src_file (char *name); +struct node *sect_nd (nodeptr op, nodeptr arg1, nodeptr arg2, + nodeptr arg3); +void tfatal (char *s1,char *s2); +struct node *to_nd (nodeptr loc_model, nodeptr arg1, + nodeptr arg2); +struct node *toby_nd (nodeptr loc_model, nodeptr arg1, + nodeptr arg2, nodeptr arg3); +int trans (void); +struct node *tree1 (int type); +struct node *tree2 (int type,struct node *loc_model); +struct node *tree3 (int type,struct node *loc_model, + struct node *c); +struct node *tree4 (int type, struct node *loc_model, + struct node *c, struct node *d); +struct node *tree5 (int type, struct node *loc_model, + struct node *c, struct node *d, + struct node *e); +struct node *tree6 (int type,struct node *loc_model, + struct node *c, struct node *d, + struct node *e, struct node *f); +void tsyserr (char *s); +void twarn (char *s1,char *s2); +struct code *typ_chk (struct il_code *var, int typcd); +int type_case (struct il_code *il, int (*fnc)(), + struct case_anlz *case_anlz); +void typeinfer (void); +struct node *unary_nd (nodeptr op, nodeptr arg); +void var_dcls (void); +#ifdef OptimizeType +int varsubtyp (struct typinfo *typ, struct lentry **single); +#else /* OptimizeType */ +int varsubtyp (unsigned int *typ, struct lentry **single); +#endif /* OptimizeType */ +void writecheck (int rc); +void yyerror (int tok,struct node *lval,int state); +int yylex (void); +int yyparse (void); +#ifdef OptimizeType +void xfer_packed_types (struct typinfo *type); +#endif /* OptimizeType */ + +#ifdef DeBug +void symdump (void); +void ldump (struct lentry **lhash); +void gdump (void); +void cdump (void); +void fdump (void); +void rdump (void); +#endif /* DeBug */ diff --git a/src/iconc/csym.c b/src/iconc/csym.c new file mode 100644 index 0000000..8e764e3 --- /dev/null +++ b/src/iconc/csym.c @@ -0,0 +1,853 @@ +/* + * csym.c -- functions for symbol table management. + */ +#include "../h/gsupport.h" +#include "cglobals.h" +#include "ctrans.h" +#include "ctree.h" +#include "ctoken.h" +#include "csym.h" +#include "ccode.h" +#include "cproto.h" + +/* + * Prototypes. + */ + +static struct gentry *alcglob (struct gentry *blink, + char *name,int flag); +static struct fentry *alcfld (struct fentry *blink, char *name, + struct par_rec *rp); +static struct centry *alclit (struct centry *blink, + char *image, int len,int flag); +static struct lentry *alcloc (struct lentry *blink, + char *name,int flag); +static struct par_rec *alcprec (struct rentry *rec, int offset, + struct par_rec *next); +static struct centry *clookup (char *image,int flag); +static struct lentry *dcl_loc (char *id, int id_type, + struct lentry *next); +static struct lentry *llookup (char *id); +static void opstrinv (struct implement *ip); +static struct gentry *putglob (char *id,int id_type); +static struct gentry *try_gbl (char *id); + +int max_sym = 0; /* max number of parameter symbols in run-time routines */ +int max_prm = 0; /* max number of parameters for any invocable routine */ + +/* + * The operands of the invocable declaration are stored in a list for + * later processing. + */ +struct strinv { + nodeptr op; + int arity; + struct strinv *next; + }; +struct strinv *strinvlst = NULL; +int op_tbl_sz; + +struct pentry *proc_lst = NULL; /* procedure list */ +struct rentry *rec_lst = NULL; /* record list */ + + +/* + *instl_p - install procedure or record in global symbol table, returning + * the symbol table entry. + */ +struct gentry *instl_p(name, flag) +char *name; +int flag; + { + struct gentry *gp; + + flag |= F_Global; + if ((gp = glookup(name)) == NULL) + gp = putglob(name, flag); + else if ((gp->flag & (~F_Global)) == 0) { + /* + * superfluous global declaration for record or proc + */ + gp->flag |= flag; + } + else /* the user can't make up his mind */ + tfatal("inconsistent redeclaration", name); + return gp; + } + +/* + * install - put an identifier into the global or local symbol table. + * The basic idea here is to look in the right table and install + * the identifier if it isn't already there. Some semantic checks + * are performed. + */ +void install(name, flag) +char *name; +int flag; + { + struct fentry *fp; + struct gentry *gp; + struct lentry *lp; + struct par_rec **rpp; + struct fldname *fnp; + int foffset; + + switch (flag) { + case F_Global: /* a variable in a global declaration */ + if ((gp = glookup(name)) == NULL) + putglob(name, flag); + else + gp->flag |= flag; + break; + + case F_Static: /* static declaration */ + ++proc_lst->nstatic; + lp = dcl_loc(name, flag, proc_lst->statics); + proc_lst->statics = lp; + break; + + case F_Dynamic: /* local declaration */ + ++proc_lst->ndynam; + lp = dcl_loc(name, flag, proc_lst->dynams); + proc_lst->dynams = lp; + break; + + case F_Argument: /* formal parameter */ + ++proc_lst->nargs; + if (proc_lst->nargs > max_prm) + max_prm = proc_lst->nargs; + lp = dcl_loc(name, flag, proc_lst->args); + proc_lst->args = lp; + break; + + case F_Field: /* field declaration */ + fnp = NewStruct(fldname); + fnp->name = name; + fnp->next = rec_lst->fields; + rec_lst->fields = fnp; + foffset = rec_lst->nfields++; + if (foffset > max_prm) + max_prm = foffset; + if ((fp = flookup(name)) == NULL) { + /* + * first occurrence of this field name. + */ + fhash[FHasher(name)] = alcfld(fhash[FHasher(name)], name, + alcprec(rec_lst, foffset, NULL)); + } + else { + rpp = &(fp->rlist); + while (*rpp != NULL && (*rpp)->offset <= foffset && + (*rpp)->rec != rec_lst) + rpp = &((*rpp)->next); + if (*rpp == NULL || (*rpp)->offset > foffset) + *rpp = alcprec(rec_lst, foffset, *rpp); + else + tfatal("duplicate field name", name); + } + break; + + default: + tsyserr("install: unrecognized symbol table flag."); + } + } + +/* + * dcl_loc - handle declaration of a local identifier. + */ +static struct lentry *dcl_loc(name, flag, next) +char *name; +int flag; +struct lentry *next; + { + register struct lentry *lp; + + if ((lp = llookup(name)) == NULL) { + lp = putloc(name,flag); + lp->next = next; + } + else if (lp->flag == flag) /* previously declared as same type */ + twarn("redeclared identifier", name); + else /* previously declared as different type */ + tfatal("inconsistent redeclaration", name); + return lp; + } + +/* + * putloc - make a local symbol table entry and return pointer to it. + */ +struct lentry *putloc(id,id_type) +char *id; +int id_type; + { + register struct lentry *ptr; + register struct lentry **lhash; + unsigned hashval; + + if ((ptr = llookup(id)) == NULL) { /* add to head of hash chain */ + lhash = proc_lst->lhash; + hashval = LHasher(id); + ptr = alcloc(lhash[hashval], id, id_type); + lhash[hashval] = ptr; + ptr->next = NULL; + } + return ptr; + } + +/* + * putglob makes a global symbol table entry and returns a pointer to it. + */ +static struct gentry *putglob(id, id_type) +char *id; +int id_type; + { + register struct gentry *ptr; + register unsigned hashval; + + if ((ptr = glookup(id)) == NULL) { /* add to head of hash chain */ + hashval = GHasher(id); + ptr = alcglob(ghash[hashval], id, id_type); + ghash[hashval] = ptr; + } + return ptr; + } + +/* + * putlit makes a constant symbol table entry and returns a pointer to it. + */ +struct centry *putlit(image, littype, len) +char *image; +int len, littype; + { + register struct centry *ptr; + register unsigned hashval; + + if ((ptr = clookup(image,littype)) == NULL) { /* add to head of hash chain */ + hashval = CHasher(image); + ptr = alclit(chash[hashval], image, len, littype); + chash[hashval] = ptr; + } + return ptr; + } + +/* + * llookup looks up id in local symbol table and returns pointer to + * to it if found or NULL if not present. + */ + +static struct lentry *llookup(id) +char *id; + { + register struct lentry *ptr; + + ptr = proc_lst->lhash[LHasher(id)]; + while (ptr != NULL && ptr->name != id) + ptr = ptr->blink; + return ptr; + } + +/* + * flookup looks up id in flobal symbol table and returns pointer to + * to it if found or NULL if not present. + */ +struct fentry *flookup(id) +char *id; + { + register struct fentry *ptr; + + ptr = fhash[FHasher(id)]; + while (ptr != NULL && ptr->name != id) { + ptr = ptr->blink; + } + return ptr; + } + +/* + * glookup looks up id in global symbol table and returns pointer to + * to it if found or NULL if not present. + */ +struct gentry *glookup(id) +char *id; + { + register struct gentry *ptr; + + ptr = ghash[GHasher(id)]; + while (ptr != NULL && ptr->name != id) { + ptr = ptr->blink; + } + return ptr; + } + +/* + * clookup looks up id in constant symbol table and returns pointer to + * to it if found or NULL if not present. + */ +static struct centry *clookup(image,flag) +char *image; +int flag; + { + register struct centry *ptr; + + ptr = chash[CHasher(image)]; + while (ptr != NULL && (ptr->image != image || ptr->flag != flag)) + ptr = ptr->blink; + + return ptr; + } + +#ifdef DeBug +/* + * symdump - dump symbol tables. + */ +void symdump() + { + struct pentry *proc; + + gdump(); + cdump(); + rdump(); + fdump(); + for (proc = proc_lst; proc != NULL; proc = proc->next) { + fprintf(stderr,"\n"); + fprintf(stderr,"Procedure %s\n", proc->sym_entry->name); + ldump(proc->lhash); + } + } + +/* + * prt_flgs - print flags from a symbol table entry. + */ +static void prt_flgs(flags) +int flags; + { + if (flags & F_Global) + fprintf(stderr, " F_Global"); + if (flags & F_Proc) + fprintf(stderr, " F_Proc"); + if (flags & F_Record) + fprintf(stderr, " F_Record"); + if (flags & F_Dynamic) + fprintf(stderr, " F_Dynamic"); + if (flags & F_Static) + fprintf(stderr, " F_Static"); + if (flags & F_Builtin) + fprintf(stderr, " F_Builtin"); + if (flags & F_StrInv) + fprintf(stderr, " F_StrInv"); + if (flags & F_ImpError) + fprintf(stderr, " F_ImpError"); + if (flags & F_Argument) + fprintf(stderr, " F_Argument"); + if (flags & F_IntLit) + fprintf(stderr, " F_IntLit"); + if (flags & F_RealLit) + fprintf(stderr, " F_RealLit"); + if (flags & F_StrLit) + fprintf(stderr, " F_StrLit"); + if (flags & F_CsetLit) + fprintf(stderr, " F_CsetLit"); + if (flags & F_Field) + fprintf(stderr, " F_Field"); + fprintf(stderr, "\n"); + } +/* + * ldump displays local symbol table to stderr. + */ + +void ldump(lhash) +struct lentry **lhash; + { + register int i; + register struct lentry *lptr; + + fprintf(stderr," Dump of local symbol table\n"); + fprintf(stderr," address name globol-ref flags\n"); + for (i = 0; i < LHSize; i++) + for (lptr = lhash[i]; lptr != NULL; lptr = lptr->blink) { + fprintf(stderr," %8x %20s ", lptr, lptr->name); + if (lptr->flag & F_Global) + fprintf(stderr, "%8x ", lptr->val.global); + else + fprintf(stderr, " - "); + prt_flgs(lptr->flag); + } + fflush(stderr); + } + +/* + * gdump displays global symbol table to stderr. + */ + +void gdump() + { + register int i; + register struct gentry *gptr; + + fprintf(stderr,"\n"); + fprintf(stderr,"Dump of global symbol table\n"); + fprintf(stderr," address name nargs flags\n"); + for (i = 0; i < GHSize; i++) + for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { + fprintf(stderr," %8x %20s %4d ", gptr, + gptr->name, gptr->nargs); + prt_flgs(gptr->flag); + } + fflush(stderr); + } + +/* + * cdump displays constant symbol table to stderr. + */ + +void cdump() + { + register int i; + register struct centry *cptr; + + fprintf(stderr,"\n"); + fprintf(stderr,"Dump of constant symbol table\n"); + fprintf(stderr, + " address value flags\n"); + for (i = 0; i < CHSize; i++) + for (cptr = chash[i]; cptr != NULL; cptr = cptr->blink) { + fprintf(stderr," %8x %-40.40s ", cptr, cptr->image); + prt_flgs(cptr->flag); + } + fflush(stderr); + } + +/* + * fdump displays field symbol table to stderr. + */ +void fdump() + { + int i; + struct par_rec *prptr; + struct fentry *fp; + + fprintf(stderr,"\n"); + fprintf(stderr,"Dump of field symbol table\n"); + fprintf(stderr, + " address field global-ref offset\n"); + for (i = 0; i < FHSize; i++) + for (fp = fhash[i]; fp != NULL; fp = fp->blink) { + fprintf(stderr," %8x %20s\n", fp, fp->name); + for (prptr = fp->rlist; prptr != NULL; prptr = prptr->next) + fprintf(stderr," %8x %4d\n", + prptr->sym_entry, prptr->offset); + } + fflush(stderr); + } + +/* + * prt_flds - print a list of fields stored in reverse order. + */ +static void prt_flds(f) +struct fldname *f; + { + if (f == NULL) + return; + prt_flds(f->next); + fprintf(stderr, " %s", f->name); + } + +/* + * rdump displays list of records and their fields. + */ +void rdump() + { + struct rentry *rp; + + fprintf(stderr,"\n"); + fprintf(stderr,"Dump of record list\n"); + fprintf(stderr, " global-ref fields\n"); + for (rp = rec_lst; rp != NULL; rp = rp->next) { + fprintf(stderr, " %8x ", rp->sym_entry); + prt_flds(rp->fields); + fprintf(stderr, "\n"); + } + } +#endif /* DeBug */ + +/* + * alcloc allocates a local symbol table entry, fills in fields with + * specified values and returns pointer to new entry. + */ +static struct lentry *alcloc(blink, name, flag) +struct lentry *blink; +char *name; +int flag; + { + register struct lentry *lp; + + lp = NewStruct(lentry); + lp->blink = blink; + lp->name = name; + lp->flag = flag; + return lp; + } + +/* + * alcfld allocates a field symbol table entry, fills in the entry with + * specified values and returns pointer to new entry. + */ +static struct fentry *alcfld(blink, name, rp) +struct fentry *blink; +char *name; +struct par_rec *rp; + { + register struct fentry *fp; + + fp = NewStruct(fentry); + fp->blink = blink; + fp->name = name; + fp->rlist = rp; + return fp; + } + +/* + * alcglob allocates a global symbol table entry, fills in fields with + * specified values and returns pointer to new entry. + */ +static struct gentry *alcglob(blink, name, flag) +struct gentry *blink; +char *name; +int flag; + { + register struct gentry *gp; + + gp = NewStruct(gentry); + gp->blink = blink; + gp->name = name; + gp->flag = flag; + return gp; + } + +/* + * alclit allocates a constant symbol table entry, fills in fields with + * specified values and returns pointer to new entry. + */ +static struct centry *alclit(blink, image, len, flag) +struct centry *blink; +char *image; +int len, flag; + { + register struct centry *cp; + + cp = NewStruct(centry); + cp->blink = blink; + cp->image = image; + cp->length = len; + cp->flag = flag; + switch (flag) { + case F_IntLit: + cp->u.intgr = iconint(image); + break; + case F_CsetLit: + cp->u.cset = bitvect(image, len); + break; + } + return cp; + } + +/* + * alcprec allocates an entry for the parent record list for a field. + */ +static struct par_rec *alcprec(rec, offset, next) +struct rentry *rec; +int offset; +struct par_rec *next; + { + register struct par_rec *rp; + + rp = NewStruct(par_rec); + rp->rec= rec; + rp->offset = offset; + rp->next = next; + return rp; + } + +/* + * resolve - resolve the scope of undeclared identifiers. + */ +void resolve(proc) +struct pentry *proc; + { + struct lentry **lhash; + register struct lentry *lp; + struct gentry *gp; + int i; + char *id; + + lhash = proc->lhash; + + for (i = 0; i < LHSize; ++i) { + lp = lhash[i]; + while (lp != NULL) { + id = lp->name; + if (lp->flag == 0) { /* undeclared */ + if ((gp = try_gbl(id)) != NULL) { /* check global */ + lp->flag = F_Global; + lp->val.global = gp; + } + else { /* implicit local */ + if (uwarn) { + fprintf(stderr, "%s undeclared identifier, procedure %s\n", + id, proc->name); + ++twarns; + } + lp->flag = F_Dynamic; + lp->next = proc->dynams; + proc->dynams = lp; + ++proc->ndynam; + } + } + lp = lp->blink; + } + } + } + +/* + * try_glb - see if the identifier is or should be a global variable. + */ +static struct gentry *try_gbl(id) +char *id; + { + struct gentry *gp; + register struct implement *iptr; + int nargs; + int n; + + gp = glookup(id); + if (gp == NULL) { + /* + * See if it is a built-in function. + */ + iptr = db_ilkup(id, bhash); + if (iptr == NULL) + return NULL; + else { + if (iptr->in_line == NULL) + nfatal(NULL, "built-in function not installed", id); + nargs = iptr->nargs; + if (nargs > 0 && iptr->arg_flgs[nargs - 1] & VarPrm) + nargs = -nargs; + gp = putglob(id, F_Global | F_Builtin); + gp->val.builtin = iptr; + + n = n_arg_sym(iptr); + if (n > max_sym) + max_sym = n; + } + } + return gp; + } + +/* + * invoc_grp - called when "invocable all" is encountered. + */ +void invoc_grp(grp) +char *grp; + { + if (grp == spec_str("all")) + str_inv = 1; /* enable full string invocation */ + else + tfatal("invalid operand to invocable", grp); + } + +/* + * invocbl - indicate that the operator is needed for for string invocation. + */ +void invocbl(op, arity) +nodeptr op; +int arity; + { + struct strinv *si; + + si = NewStruct(strinv); + si->op = op; + si->arity = arity; + si->next = strinvlst; + strinvlst = si; + } + +/* + * chkstrinv - check to see what is needed for string invocation. + */ +void chkstrinv() + { + struct strinv *si; + struct gentry *gp; + struct implement *ip; + char *op_name; + int arity; + int i; + + /* + * A table of procedure blocks for operators is set up for use by + * string invocation. + */ + op_tbl_sz = 0; + fprintf(codefile, "\nstatic B_IProc(2) init_op_tbl[OpTblSz]"); + + if (str_inv) { + /* + * All operations must be available for string invocation. Make sure all + * built-in functions have either been hidden by global declarations + * or are in global variables, make sure no global variables are + * optimized away, and make sure all operations are in the table of + * operations. + */ + for (i = 0; i < IHSize; ++i) /* built-in function table */ + for (ip = bhash[i]; ip != NULL; ip = ip->blink) + try_gbl(ip->name); + for (i = 0; i < GHSize; i++) /* global symbol table */ + for (gp = ghash[i]; gp != NULL; gp = gp->blink) + gp->flag |= F_StrInv; + for (i = 0; i < IHSize; ++i) /* operator table */ + for (ip = ohash[i]; ip != NULL; ip = ip->blink) + opstrinv(ip); + } + else { + /* + * selected operations must be available for string invocation. + */ + for (si = strinvlst; si != NULL; si = si->next) { + op_name = Str0(si->op); + if (isalpha(*op_name) || (*op_name == '_')) { + /* + * This needs to be something in a global variable: function, + * procedure, or constructor. + */ + gp = try_gbl(op_name); + if (gp == NULL) + nfatal(si->op, "not available for string invocation", op_name); + else + gp->flag |= F_StrInv; + } + else { + /* + * must be an operator. + */ + arity = si->arity; + i = IHasher(op_name); + for (ip = ohash[i]; ip != NULL && ip->op != op_name; + ip = ip->blink) + ; + if (arity < 0) { + /* + * Operators of all arities with this symbol. + */ + while (ip != NULL && ip->op == op_name) { + opstrinv(ip); + ip = ip->blink; + } + } + else { + /* + * Operator of a specific arity. + */ + while (ip != NULL && ip->nargs != arity) + ip = ip->blink; + if (ip == NULL || ip->op != op_name) + nfatal(si->op, "not available for string invocation", + op_name); + else + opstrinv(ip); + } + } + } + } + + /* + * Add definitions to the header file indicating the size of the operator + * table and finish the declaration in the code file. + */ + if (op_tbl_sz == 0) { + fprintf(inclfile, "#define OpTblSz 1\n"); + fprintf(inclfile, "int op_tbl_sz = 0;\n"); + fprintf(codefile, ";\n"); + } + else { + fprintf(inclfile, "#define OpTblSz %d\n", op_tbl_sz); + fprintf(inclfile, "int op_tbl_sz = OpTblSz;\n"); + fprintf(codefile, "\n };\n"); + } + } + +/* + * opstrinv - set up string invocation for an operator. + */ +static void opstrinv(ip) +struct implement *ip; + { + char c1, c2; + char *name; + char *op; + register char *s; + int nargs; + int n; + + if (ip == NULL || ip->iconc_flgs & InStrTbl) + return; + + /* + * Keep track of the maximum number of argument symbols in any operation + * so type inference can allocate enough storage for the worst case of + * general invocation. + */ + n = n_arg_sym(ip); + if (n > max_sym) + max_sym = n; + + name = ip->name; + c1 = ip->prefix[0]; + c2 = ip->prefix[1]; + op = ip->op; + nargs = ip->nargs; + if (ip->arg_flgs[nargs - 1] & VarPrm) + nargs = -nargs; /* indicate varargs with negative number of params */ + + if (op_tbl_sz++ == 0) { + fprintf(inclfile, "\n"); + fprintf(codefile, " = {\n"); + } + else + fprintf(codefile, ",\n"); + implproto(ip); /* output prototype */ + + /* + * Output procedure block for this operator into table used by string + * invocation. + */ + fprintf(codefile, " {T_Proc, 11, O%c%c_%s, %d, -1, 0, 0, {{%d, \"", c1, c2, + name, nargs, strlen(op)); + for (s = op; *s != '\0'; ++s) { + if (*s == '\\') + fprintf(codefile, "\\"); + fprintf(codefile, "%c", *s); + } + fprintf(codefile, "\"}}}"); + ip->iconc_flgs |= InStrTbl; + } + +/* + * n_arg_sym - determine the number of argument symbols (dereferenced + * and undereferenced arguments are separate symbols) for an operation + * in the data base. + */ +int n_arg_sym(ip) +struct implement *ip; + { + int i; + int num; + + num = 0; + for (i = 0; i < ip->nargs; ++i) { + if (ip->arg_flgs[i] & RtParm) + ++num; + if (ip->arg_flgs[i] & DrfPrm) + ++num; + } + return num; + } diff --git a/src/iconc/csym.h b/src/iconc/csym.h new file mode 100644 index 0000000..cf104af --- /dev/null +++ b/src/iconc/csym.h @@ -0,0 +1,380 @@ +/* + * Structures for symbol table entries. + */ + +#define MaybeTrue 1 /* condition might be true at run time */ +#define MaybeFalse 2 /* condition might be false at run time */ + +#define MayConvert 1 /* type conversion may convert the value */ +#define MayDefault 2 /* defaulting type conversion may use default */ +#define MayKeep 4 /* conversion may succeed without any actual conversion */ + +#ifdef OptimizeType +#define NULL_T 0x1000000 +#define REAL_T 0x2000000 +#define INT_T 0x4000000 +#define CSET_T 0x8000000 +#define STR_T 0x10000000 + +#define TYPINFO_BLOCK 400000 + +/* + * Optimized type structure for bit vectors + * All previous occurencess of unsigned int * (at least + * when refering to bit vectors) have been replaced by + * struct typinfo. + */ +struct typinfo { + unsigned int packed; /* packed representation of types */ + unsigned int *bits; /* full length bit vector */ +}; +#endif /* OptimizeType */ + +/* + * Data base type codes are mapped to type inferencing information using + * an array. + */ +struct typ_info { + int frst_bit; /* first bit in bit vector allocated to this type */ + int num_bits; /* number of bits in bit vector allocated to this type */ + int new_indx; /* index into arrays of allocated types for operation */ +#ifdef OptimizeType + struct typinfo *typ; /* for variables: initial type */ +#else /* OptimizeType */ + unsigned int *typ; /* for variabled: initial type */ +#endif /* OptimizeType */ + }; + +/* + * A type is a bit vector representing a union of basic types. There + * are 3 sizes of types: first class types (Icon language types), + * intermediate value types (first class types plus variable references), + * run-time routine types (intermediate value types plus internal + * references to descriptors such as set elements). When the size of + * the type is known from context, a simple bit vector can be used. + * In other contexts, the size must be included. + */ +struct type { + int size; +#ifdef OptimizeType + struct typinfo *bits; +#else /* OptimizeType */ + unsigned int *bits; +#endif /* OptimizeType */ + struct type *next; + }; + + +#define DecodeSize(x) (x & 0xFFFFFF) +#define DecodePacked(x) (x >> 24) +/* + * NumInts - convert from the number of bits in a bit vector to the + * number of integers implementing it. + */ +#define NumInts(n_bits) (n_bits - 1) / IntBits + 1 + +/* + * ClrTyp - zero out the bit vector for a type. + */ +#ifdef OptimizeType +#define ClrTyp(size,typ) {\ + int typ_indx;\ + if ((typ)->bits == NULL)\ + clr_packed((typ),(size));\ + else\ + for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ + (typ)->bits[typ_indx] = 0;} +#else /* OptimizeType */ +#define ClrTyp(size,typ) {\ + int typ_indx;\ + for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ + (typ)[typ_indx] = 0;} +#endif /* OptimizeType */ + +/* + * CpyTyp - copy a type of the given size from one bit vector to another. + */ +#ifdef OptimizeType +#define CpyTyp(nsize,src,dest) {\ + int typ_indx, num;\ + if (((src)->bits == NULL) && ((dest)->bits == NULL)) {\ + ClrTyp((nsize),(dest));\ + cpy_packed_to_packed((src),(dest),(nsize));\ + }\ + else if (((src)->bits == NULL) && ((dest)->bits != NULL)) {\ + ClrTyp((nsize),(dest));\ + xfer_packed_to_bits((src),(dest),(nsize));\ + }\ + else if (((src)->bits != NULL) && ((dest)->bits == NULL)) {\ + (dest)->bits = alloc_mem_typ(DecodeSize((dest)->packed));\ + xfer_packed_types((dest));\ + for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ + (dest)->bits[typ_indx] = (src)->bits[typ_indx];\ + }\ + else\ + for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ + (dest)->bits[typ_indx] = (src)->bits[typ_indx];} +#else /* OptimizeType */ +#define CpyTyp(size,src,dest) {\ + int typ_indx;\ + for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ + (dest)[typ_indx] = (src)[typ_indx];} +#endif /* OptimizeType */ + +/* + * MrgTyp - merge a type of the given size from one bit vector into another. + */ +#ifdef OptimizeType +#define MrgTyp(nsize,src,dest) {\ + int typ_indx;\ + if (((src)->bits == NULL) && ((dest)->bits == NULL))\ + mrg_packed_to_packed((src),(dest),(nsize));\ + else if (((src)->bits == NULL) && ((dest)->bits != NULL))\ + xfer_packed_to_bits((src),(dest),(nsize));\ + else if (((src)->bits != NULL) && ((dest)->bits == NULL)) {\ + (dest)->bits = alloc_mem_typ(DecodeSize((dest)->packed));\ + xfer_packed_types((dest));\ + for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ + (dest)->bits[typ_indx] |= (src)->bits[typ_indx];\ + }\ + else\ + for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx)\ + (dest)->bits[typ_indx] |= (src)->bits[typ_indx];} +#else /* OptimizeType */ +#define MrgTyp(size,src,dest) {\ + int typ_indx;\ + for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx)\ + (dest)[typ_indx] |= (src)[typ_indx];} +#endif /* OptimizeType */ + +/* + * ChkMrgTyp - merge a type of the given size from one bit vector into another, + * updating the changed flag if the destination is changed by the merger. + */ +#ifdef OptimizeType +#define ChkMrgTyp(nsize,src,dest) {\ + int typ_indx, ret; unsigned int old;\ + if (((src)->bits == NULL) && ((dest)->bits == NULL)) {\ + ret = mrg_packed_to_packed((src),(dest),(nsize));\ + changed += ret;\ + }\ + else if (((src)->bits == NULL) && ((dest)->bits != NULL)) {\ + ret = xfer_packed_to_bits((src),(dest),(nsize));\ + changed += ret;\ + }\ + else if (((src)->bits != NULL) && ((dest)->bits == NULL)) {\ + (dest)->bits = alloc_mem_typ(DecodeSize((dest)->packed));\ + xfer_packed_types((dest));\ + for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx) {\ + old = (dest)->bits[typ_indx];\ + (dest)->bits[typ_indx] |= (src)->bits[typ_indx];\ + if (old != (dest)->bits[typ_indx]) ++changed;}\ + }\ + else\ + for (typ_indx = 0; typ_indx < NumInts((nsize)); ++typ_indx) {\ + old = (dest)->bits[typ_indx];\ + (dest)->bits[typ_indx] |= (src)->bits[typ_indx];\ + if (old != (dest)->bits[typ_indx]) ++changed;}} +#else /* OptimizeType */ +#define ChkMrgTyp(size,src,dest) {\ + int typ_indx; unsigned int old;\ + for (typ_indx = 0; typ_indx < NumInts((size)); ++typ_indx) {\ + old = (dest)[typ_indx];\ + (dest)[typ_indx] |= (src)[typ_indx];\ + if (old != (dest)[typ_indx]) ++changed;}} +#endif /* OptimizeType */ + + +struct centry { /* constant table entry */ + struct centry *blink; /* link for bucket chain */ + char *image; /* pointer to string image of literal */ + int length; /* length of string */ + union { + unsigned short *cset; /* pointer to bit string for cset literal */ + long intgr; /* value of integer literal */ + } u; + uword flag; /* type of literal flag */ + char prefix[PrfxSz+1]; /* unique prefix used in data block name */ + }; + +struct fentry { /* field table entry */ + struct fentry *blink; /* link for bucket chain */ + char *name; /* name of field */ + struct par_rec *rlist; /* head of list of records */ + }; + +struct lentry { /* local table entry */ + struct lentry *blink; /* link for bucket chain */ + char *name; /* name of variable */ + uword flag; /* variable flags */ + union { + struct gentry *global; /* for globals: global symbol table entry */ + int index; /* type index; run-time descriptor index */ + } val; + struct lentry *next; /* used for linking a class of variables */ + }; + +struct gentry { /* global table entry */ + struct gentry *blink; /* link for bucket chain */ + char *name; /* name of variable */ + uword flag; /* variable flags */ + union { + struct implement *builtin; /* pointer to built-in function */ + struct pentry *proc; /* pointer to procedure entry */ + struct rentry *rec; /* pointer to record entry */ + } val; + int index; /* index into global array */ + int init_type; /* initial type if procedure */ + }; + +/* + * Structure for list of parent records for a field name. + */ +struct par_rec { + struct rentry *rec; /* parent record */ + int offset; /* field's offset within this record */ + int mark; /* used during code generation */ + struct par_rec *next; + }; + +/* + * Structure for a procedure. + */ +struct pentry { + char *name; /* name of procedure */ + char prefix[PrfxSz+1]; /* prefix to make name unique */ + struct lentry **lhash; /* hash area for procedure's local table */ + int nargs; /* number of args */ + struct lentry *args; /* list of arguments in reverse order */ + int ndynam; /* number of dynamic locals */ + struct lentry *dynams; /* list of dynamics in reverse order */ + int nstatic; /* number of statics */ + struct lentry *statics; /* list of statics in reverse order */ + struct node *tree; /* syntax tree for procedure */ + int has_coexpr; /* this procedure contains co-expressions */ + int tnd_loc; /* number of tended dynamic locals */ + int ret_flag; /* proc returns, suspends, and/or fails */ + int reachable; /* this procedure may be executed */ + int iteration; /* last iteration of type inference performed */ + int arg_lst; /* for varargs - the type number of the list */ +#ifdef OptimizeType + struct typinfo *ret_typ; /* type returned from procedure */ +#else /* OptimizeType */ + unsigned int *ret_typ; /* type returned from procedure */ +#endif /* OptimizeType */ + struct store *in_store; /* store at start of procedure */ + struct store *susp_store; /* store for resumption points of procedure */ + struct store *out_store; /* store on exiting procedure */ + struct lentry **vartypmap; /* mapping from var types to symtab entries */ +#ifdef OptimizeType + struct typinfo *coexprs; /* co-expressions in which proc may be called */ +#else /* OptimizeType */ + unsigned int *coexprs; /* co-expressions in which proc may be called */ +#endif /* OptimizeType */ + struct pentry *next; + }; + +/* + * Structure for a record. + */ +struct rentry { + char *name; /* name of record */ + char prefix[PrfxSz+1]; /* prefix to make name unique */ + int frst_fld; /* offset of variable type of 1st field */ + int nfields; /* number of fields */ + struct fldname *fields; /* list of field names in reverse order */ + int rec_num; /* id number for record */ + struct rentry *next; + }; + +struct fldname { /* record field */ + char *name; /* field name */ + struct fldname *next; + }; + +/* + * Structure used to analyze whether a type_case statement can be in-lined. + * Only one type check is supported: the type_case will be implemented + * as an "if" statement. + */ +struct case_anlz { + int n_cases; /* number of cases actually needed for this use */ + int typcd; /* for "if" optimization, the type code to check */ + struct il_code *il_then; /* for "if" optimization, the then clause */ + struct il_code *il_else; /* for "if" optimization, the else clause */ + }; + +/* + * spec_op contains the implementations for operations with do not have + * standard unary/binary syntax. + */ +#define ToOp 0 /* index into spec_op of i to j */ +#define ToByOp 1 /* index into spec_op of i to j by k */ +#define SectOp 2 /* index into spec_op of x[i:j] */ +#define SubscOp 3 /* index into spec_op of x[i] */ +#define ListOp 4 /* index into spec_op of [e1, e2, ... ] */ +#define NumSpecOp 5 +extern struct implement *spec_op[NumSpecOp]; + +/* + * Flag values. + */ + +#define F_Global 01 /* variable declared global externally */ +#define F_Proc 04 /* procedure */ +#define F_Record 010 /* record */ +#define F_Dynamic 020 /* variable declared local dynamic */ +#define F_Static 040 /* variable declared local static */ +#define F_Builtin 0100 /* identifier refers to built-in procedure */ +#define F_StrInv 0200 /* variable needed for string invocation */ +#define F_ImpError 0400 /* procedure has default error */ +#define F_Argument 01000 /* variable is a formal parameter */ +#define F_IntLit 02000 /* literal is an integer */ +#define F_RealLit 04000 /* literal is a real */ +#define F_StrLit 010000 /* literal is a string */ +#define F_CsetLit 020000 /* literal is a cset */ +#define F_Field 040000 /* identifier refers to a record field */ +#define F_SmplInv 0100000 /* identifier only used in simple invocation */ + +/* + * Symbol table region pointers. + */ + +extern struct implement *bhash[]; /* hash area for built-in func table */ +extern struct centry *chash[]; /* hash area for constant table */ +extern struct fentry *fhash[]; /* hash area for field table */ +extern struct gentry *ghash[]; /* hash area for global table */ +extern struct implement *khash[]; /* hash area for keyword table */ +extern struct implement *ohash[]; /* hash area for operator table */ + +extern struct pentry *proc_lst; /* procedure list */ +extern struct rentry *rec_lst; /* record list */ + +extern int max_sym; /* max number of parameter symbols in run-time routines */ +extern int max_prm; /* max number of parameters for any invocable routine */ + +extern struct symtyps *cur_symtyps; /* maps run-time routine symbols to types */ +extern struct pentry *cur_proc; /* procedure currently being translated */ + +/* + * Hash functions for symbol tables. Note, hash table sizes (xHSize) + * are all a power of 2. + */ + +#define CHasher(x) (((word)x)&(CHSize-1)) /* constant symbol table */ +#define FHasher(x) (((word)x)&(FHSize-1)) /* field symbol table */ +#define GHasher(x) (((word)x)&(GHSize-1)) /* global symbol table */ +#define LHasher(x) (((word)x)&(LHSize-1)) /* local symbol table */ + +/* + * flags for implementation entries. + */ +#define ProtoPrint 1 /* a prototype has already been printed */ +#define InStrTbl 2 /* operator is in string table */ + +/* + * Whether an operation can fail may depend on whether error conversion + * is allowed. The following macro checks this. + */ +#define MightFail(ret_flag) ((ret_flag & DoesFail) ||\ + (err_conv && (ret_flag & DoesEFail))) diff --git a/src/iconc/ctoken.h b/src/iconc/ctoken.h new file mode 100644 index 0000000..1e95e98 --- /dev/null +++ b/src/iconc/ctoken.h @@ -0,0 +1,111 @@ +# define IDENT 257 +# define INTLIT 258 +# define REALLIT 259 +# define STRINGLIT 260 +# define CSETLIT 261 +# define EOFX 262 +# define BREAK 263 +# define BY 264 +# define CASE 265 +# define CREATE 266 +# define DEFAULT 267 +# define DO 268 +# define ELSE 269 +# define END 270 +# define EVERY 271 +# define FAIL 272 +# define GLOBAL 273 +# define IF 274 +# define INITIAL 275 +# define INVOCABLE 276 +# define LINK 277 +# define LOCAL 278 +# define NEXT 279 +# define NOT 280 +# define OF 281 +# define PROCEDURE 282 +# define RECORD 283 +# define REPEAT 284 +# define RETURN 285 +# define STATIC 286 +# define SUSPEND 287 +# define THEN 288 +# define TO 289 +# define UNTIL 290 +# define WHILE 291 +# define BANG 292 +# define MOD 293 +# define AUGMOD 294 +# define AND 295 +# define AUGAND 296 +# define STAR 297 +# define AUGSTAR 298 +# define INTER 299 +# define AUGINTER 300 +# define PLUS 301 +# define AUGPLUS 302 +# define UNION 303 +# define AUGUNION 304 +# define MINUS 305 +# define AUGMINUS 306 +# define DIFF 307 +# define AUGDIFF 308 +# define DOT 309 +# define SLASH 310 +# define AUGSLASH 311 +# define ASSIGN 312 +# define SWAP 313 +# define NMLT 314 +# define AUGNMLT 315 +# define REVASSIGN 316 +# define REVSWAP 317 +# define SLT 318 +# define AUGSLT 319 +# define SLE 320 +# define AUGSLE 321 +# define NMLE 322 +# define AUGNMLE 323 +# define NMEQ 324 +# define AUGNMEQ 325 +# define SEQ 326 +# define AUGSEQ 327 +# define EQUIV 328 +# define AUGEQUIV 329 +# define NMGT 330 +# define AUGNMGT 331 +# define NMGE 332 +# define AUGNMGE 333 +# define SGT 334 +# define AUGSGT 335 +# define SGE 336 +# define AUGSGE 337 +# define QMARK 338 +# define AUGQMARK 339 +# define AT 340 +# define AUGAT 341 +# define BACKSLASH 342 +# define CARET 343 +# define AUGCARET 344 +# define BAR 345 +# define CONCAT 346 +# define AUGCONCAT 347 +# define LCONCAT 348 +# define AUGLCONCAT 349 +# define TILDE 350 +# define NMNE 351 +# define AUGNMNE 352 +# define SNE 353 +# define AUGSNE 354 +# define NEQUIV 355 +# define AUGNEQUIV 356 +# define LPAREN 357 +# define RPAREN 358 +# define PCOLON 359 +# define COMMA 360 +# define MCOLON 361 +# define COLON 362 +# define SEMICOL 363 +# define LBRACK 364 +# define RBRACK 365 +# define LBRACE 366 +# define RBRACE 367 diff --git a/src/iconc/ctrans.c b/src/iconc/ctrans.c new file mode 100644 index 0000000..7d33ac5 --- /dev/null +++ b/src/iconc/ctrans.c @@ -0,0 +1,184 @@ +/* + * ctrans.c - main control of the translation process. + */ +#include "../h/gsupport.h" +#include "cglobals.h" +#include "ctrans.h" +#include "csym.h" +#include "ctree.h" +#include "ctoken.h" +#include "ccode.h" +#include "cproto.h" + +/* + * Prototypes. + */ +static void trans1 (char *filename); + +/* + * Variables. + */ +int tfatals = 0; /* total number of fatal errors */ +int twarns = 0; /* total number of warnings */ +int nocode; /* set by lexer; unused in compiler */ +int in_line; /* current input line number */ +int incol; /* current input column number */ +int peekc; /* one-character look ahead */ +struct srcfile *srclst = NULL; /* list of source files to translate */ + +static char *lpath; /* LPATH value */ + +/* + * translate a number of files, returning an error count + */ +int trans() + { + register struct pentry *proc; + struct srcfile *sf; + + lpath = getenv("LPATH"); /* remains null if unspecified */ + + for (sf = srclst; sf != NULL; sf = sf->next) + trans1(sf->name); /* translate each file in turn */ + + if (!pponly) { + /* + * Resolve undeclared references. + */ + for (proc = proc_lst; proc != NULL; proc = proc->next) + resolve(proc); + +#ifdef DeBug + symdump(); +#endif /* DeBug */ + + if (tfatals == 0) { + chkstrinv(); /* see what needs be available for string invocation */ + chkinv(); /* perform "naive" optimizations */ + } + + if (tfatals == 0) + typeinfer(); /* perform type inference */ + + if (just_type_trace) + return tfatals; /* stop without generating code */ + + if (tfatals == 0) { + var_dcls(); /* output declarations for globals and statics */ + const_blks(); /* output blocks for cset and real literals */ + for (proc = proc_lst; proc != NULL; proc = proc->next) + proccode(proc); /* output code for a procedure */ + recconstr(rec_lst); /* output code for record constructors */ +/* ANTHONY */ +/* + print_ghash(); +*/ + } + } + + /* + * Report information about errors and warnings and be correct about it. + */ + if (tfatals == 1) + fprintf(stderr, "1 error; "); + else if (tfatals > 1) + fprintf(stderr, "%d errors; ", tfatals); + else if (verbose > 0) + fprintf(stderr, "No errors; "); + + if (twarns == 1) + fprintf(stderr, "1 warning\n"); + else if (twarns > 1) + fprintf(stderr, "%d warnings\n", twarns); + else if (verbose > 0) + fprintf(stderr, "no warnings\n"); + else if (tfatals > 0) + fprintf(stderr, "\n"); + +#ifdef TranStats + tokdump(); +#endif /* TranStats */ + + return tfatals; + } + +/* + * translate one file. + */ +static void trans1(filename) +char *filename; + { + in_line = 1; /* start with line 1, column 0 */ + incol = 0; + peekc = 0; /* clear character lookahead */ + + if (!ppinit(filename,lpath?lpath:".",m4pre)) { + tfatal(filename, "cannot open source file"); + return; + } + if (!largeints) /* undefine predef symbol if no -l option */ + ppdef("_LARGE_INTEGERS", (char *)NULL); + ppdef("_MULTITASKING", (char *)NULL); /* never defined in compiler */ + ppdef("_EVENT_MONITOR", (char *)NULL); + ppdef("_MEMORY_MONITOR", (char *)NULL); + ppdef("_VISUALIZATION", (char *)NULL); + + if (strcmp(filename,"-") == 0) + filename = "stdin"; + if (verbose > 0) + fprintf(stderr, "%s:\n",filename); + + tok_loc.n_file = filename; + in_line = 1; + + if (pponly) + ppecho(); /* preprocess only */ + else + yyparse(); /* Parse the input */ + } + +/* + * writecheck - check the return code from a stdio output operation + */ +void writecheck(rc) + int rc; + + { + if (rc < 0) + quit("unable to write to icode file"); + } + +/* + * lnkdcl - find file locally or on LPATH and add to source list. + */ +void lnkdcl(name) +char *name; +{ + struct srcfile **pp; + struct srcfile *p; + char buf[MaxPath]; + + if (pathfind(buf, lpath, name, SourceSuffix)) + src_file(buf); + else + tfatal("cannot resolve reference to file name", name); + } + +/* + * src_file - add the file name to the list of source files to be translated, + * if it is not already on the list. + */ +void src_file(name) +char *name; + { + struct srcfile **pp; + struct srcfile *p; + + for (pp = &srclst; *pp != NULL; pp = &(*pp)->next) + if (strcmp((*pp)->name, name) == 0) + return; + p = NewStruct(srcfile); + p->name = salloc(name); + p->next = NULL; + *pp = p; +} diff --git a/src/iconc/ctrans.h b/src/iconc/ctrans.h new file mode 100644 index 0000000..3e03d06 --- /dev/null +++ b/src/iconc/ctrans.h @@ -0,0 +1,47 @@ +/* + * Miscellaneous compiler-specific definitions. + */ + +#define Iconc + +#ifndef CUsage + #define CUsage "[-C C-comp] [-E] [-T] [-c] [-f{adelns}] [-n{acest}]\n\ + [-o ofile] [-p C-opts] [-r runtime] [-s] [-t] [-u] [-v i]" +#endif /* CUsage */ + +#define Abs(n) ((n) >= 0 ? (n) : -(n)) +#define Max(x,y) ((x)>(y)?(x):(y)) + +#define tonum(c) (isdigit(c) ? (c - '0') : ((c & 037) + 9)) + +/* + * Hash tables must be a power of 2. + */ +#define CHSize 128 /* size of constant hash table */ +#define FHSize 32 /* size of field hash table */ +#define GHSize 128 /* size of global hash table */ +#define LHSize 128 /* size of local hash table */ + +#define PrfxSz 3 /* size of prefix */ + +/* + * srcfile is used construct the queue of source files to be translated. + */ +struct srcfile { + char *name; + struct srcfile *next; + }; + +extern struct srcfile *srclst; + +/* + * External definitions needed throughout translator. + */ +extern int twarns; + +#ifdef TranStats +#include "tstats.h" +#else /* TranStats */ +#define TokInc(x) +#define TokDec(x) +#endif /* TranStats */ diff --git a/src/iconc/ctree.c b/src/iconc/ctree.c new file mode 100644 index 0000000..170a631 --- /dev/null +++ b/src/iconc/ctree.c @@ -0,0 +1,777 @@ +/* + * ctree.c -- functions for constructing parse trees. + */ +#include "../h/gsupport.h" +#include "../h/lexdef.h" +#include "ctrans.h" +#include "ctree.h" +#include "csym.h" +#include "ctoken.h" +#include "ccode.h" +#include "cproto.h" + +/* + * prototypes for static functions. + */ +static nodeptr chk_empty (nodeptr n); +static void put_elms (nodeptr t, nodeptr args, int slot); +static nodeptr subsc_nd (nodeptr op, nodeptr arg1, nodeptr arg2); + +/* + * tree[1-6] construct parse tree nodes with specified values. + * loc_model is a node containing the same line and column information + * as is needed in this node, while parameters a through d are values to + * be assigned to n_field[0-3]. Note that this could be done with a + * single routine; a separate routine for each node size is used for + * speed and simplicity. + */ + +nodeptr tree1(type) +int type; + { + register nodeptr t; + + t = NewNode(0); + t->n_type = type; + t->n_file = NULL; + t->n_line = 0; + t->n_col = 0; + t->freetmp = NULL; + return t; + } + +nodeptr tree2(type, loc_model) +int type; +nodeptr loc_model; + { + register nodeptr t; + + t = NewNode(0); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + return t; + } + +nodeptr tree3(type, loc_model, a) +int type; +nodeptr loc_model; +nodeptr a; + { + register nodeptr t; + + t = NewNode(1); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + t->n_field[0].n_ptr = a; + return t; + } + +nodeptr tree4(type, loc_model, a, b) +int type; +nodeptr loc_model; +nodeptr a, b; + { + register nodeptr t; + + t = NewNode(2); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + t->n_field[0].n_ptr = a; + t->n_field[1].n_ptr = b; + return t; + } + +nodeptr tree5(type, loc_model, a, b, c) +int type; +nodeptr loc_model; +nodeptr a, b, c; + { + register nodeptr t; + + t = NewNode(3); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + t->n_field[0].n_ptr = a; + t->n_field[1].n_ptr = b; + t->n_field[2].n_ptr = c; + return t; + } + +nodeptr tree6(type, loc_model, a, b, c, d) +int type; +nodeptr loc_model; +nodeptr a, b, c, d; + { + register nodeptr t; + + t = NewNode(4); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + t->n_field[0].n_ptr = a; + t->n_field[1].n_ptr = b; + t->n_field[2].n_ptr = c; + t->n_field[3].n_ptr = d; + return t; + } + +nodeptr int_leaf(type, loc_model, a) +int type; +nodeptr loc_model; +int a; + { + register nodeptr t; + + t = NewNode(1); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + t->n_field[0].n_val = a; + return t; + } + +nodeptr c_str_leaf(type, loc_model, a) +int type; +nodeptr loc_model; +char *a; + { + register nodeptr t; + + t = NewNode(1); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + t->n_field[0].n_str = a; + return t; + } + +/* + * i_str_leaf - create a leaf node containing a string and length. + */ +nodeptr i_str_leaf(type, loc_model, a, b) +int type; +nodeptr loc_model; +char *a; +int b; + { + register nodeptr t; + + t = NewNode(2); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + t->n_field[0].n_str = a; + t->n_field[1].n_val = b; + return t; + } + +/* + * key_leaf - create a leaf node for a keyword. + */ +nodeptr key_leaf(loc_model, keyname) +nodeptr loc_model; +char *keyname; + { + register nodeptr t; + struct implement *ip; + struct il_code *il; + char *s; + int typcd; + + /* + * Find the data base entry for the keyword, if it exists. + */ + ip = db_ilkup(keyname, khash); + + if (ip == NULL) + tfatal("invalid keyword", keyname); + else if (ip->in_line == NULL) + tfatal("keyword not installed", keyname); + else { + il = ip->in_line; + s = il->u[1].s; + if (il->il_type == IL_Const) { + /* + * This is a constant keyword, treat it as a literal. + */ + t = NewNode(1); + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + typcd = il->u[0].n; + if (typcd == cset_typ) { + t->n_type = N_Cset; + CSym0(t) = putlit(&s[1], F_CsetLit, strlen(s) - 2); + } + else if (typcd == int_typ) { + t->n_type = N_Int; + CSym0(t) = putlit(s, F_IntLit, 0); + } + else if (typcd == real_typ) { + t->n_type = N_Real; + CSym0(t) = putlit(s, F_RealLit, 0); + } + else if (typcd == str_typ) { + t->n_type = N_Str; + CSym0(t) = putlit(&s[1], F_StrLit, strlen(s) - 2); + } + return t; + } + } + + t = NewNode(2); + t->n_type = N_InvOp; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + t->n_field[0].n_val = 0; /* number of arguments */ + t->n_field[1].ip = ip; + return t; + } + +/* + * list_nd - create a list creation node. + */ +nodeptr list_nd(loc_model, args) +nodeptr loc_model; +nodeptr args; + { + register nodeptr t; + struct implement *impl; + int nargs; + + /* + * Determine the number of arguments. + */ + if (args->n_type == N_Empty) + nargs = 0; + else { + nargs = 1; + for (t = args; t->n_type == N_Elist; t = t->n_field[0].n_ptr) + ++nargs; + if (nargs > max_prm) + max_prm = nargs; + } + + impl = spec_op[ListOp]; + if (impl == NULL) + nfatal(loc_model, "list creation not implemented", NULL); + else if (impl->in_line == NULL) + nfatal(loc_model, "list creation not installed", NULL); + + t = NewNode(nargs + 2); + t->n_type = N_InvOp; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + t->n_field[0].n_val = nargs; + t->n_field[1].ip = impl; + if (nargs > 0) + put_elms(t, args, nargs + 1); + return t; + } + +/* + * invk_nd - create a node for invocation. + */ +nodeptr invk_nd(loc_model, proc, args) +nodeptr loc_model; +nodeptr proc; +nodeptr args; + { + register nodeptr t; + int nargs; + + /* + * Determine the number of arguments. + */ + if (args->n_type == N_Empty) + nargs = 0; + else { + nargs = 1; + for (t = args; t->n_type == N_Elist; t = t->n_field[0].n_ptr) + ++nargs; + if (nargs > max_prm) + max_prm = nargs; + } + + t = NewNode(nargs + 2); + t->n_type = N_Invok; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + t->n_field[0].n_val = nargs; + t->n_field[1].n_ptr = proc; + if (nargs > 0) + put_elms(t, args, nargs + 1); + return t; + } + +/* + * put_elms - convert a linked list of arguments into an array of arguments + * in a node. + */ +static void put_elms(t, args, slot) +nodeptr t; +nodeptr args; +int slot; + { + if (args->n_type == N_Elist) { + /* + * The linked list is in reverse argument order. + */ + t->n_field[slot].n_ptr = chk_empty(args->n_field[1].n_ptr); + put_elms(t, args->n_field[0].n_ptr, slot - 1); + free(args); + } + else + t->n_field[slot].n_ptr = chk_empty(args); + } + +/* + * chk_empty - if an argument is empty, replace it with &null. + */ +static nodeptr chk_empty(n) +nodeptr n; + { + if (n->n_type == N_Empty) + n = key_leaf(n, spec_str("null")); + return n; + } + +/* + * case_nd - create a node for a case statement. + */ +nodeptr case_nd(loc_model, expr, cases) +nodeptr loc_model; +nodeptr expr; +nodeptr cases; + { + register nodeptr t; + nodeptr reverse; + nodeptr nxt_cases; + nodeptr ccls; + + t = NewNode(3); + t->n_type = N_Case; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->freetmp = NULL; + t->n_field[0].n_ptr = expr; + t->n_field[2].n_ptr = NULL; + + /* + * The list of cases is in reverse order. Walk the list reversing it, + * and extract the default clause if one exists. + */ + reverse = NULL; + while (cases->n_type != N_Ccls) { + nxt_cases = cases->n_field[0].n_ptr; + ccls = cases->n_field[1].n_ptr; + if (ccls->n_field[0].n_ptr->n_type == N_Res) { + /* + * default clause. + */ + if (t->n_field[2].n_ptr == NULL) + t->n_field[2].n_ptr = ccls->n_field[1].n_ptr; + else + nfatal(ccls, "duplicate default clause", NULL); + } + else { + if (reverse == NULL) { + reverse = cases; + reverse->n_field[0].n_ptr = ccls; + } + else { + reverse->n_field[1].n_ptr = ccls; + cases->n_field[0].n_ptr = reverse; + reverse = cases; + } + } + cases = nxt_cases; + } + + /* + * Last element in list. + */ + if (cases->n_field[0].n_ptr->n_type == N_Res) { + /* + * default clause. + */ + if (t->n_field[2].n_ptr == NULL) + t->n_field[2].n_ptr = cases->n_field[1].n_ptr; + else + nfatal(ccls, "duplicate default clause", NULL); + if (reverse != NULL) + reverse = reverse->n_field[0].n_ptr; + } + else { + if (reverse == NULL) + reverse = cases; + else + reverse->n_field[1].n_ptr = cases; + } + t->n_field[1].n_ptr = reverse; + return t; + } + +/* + * multiunary - construct nodes to implement a sequence of unary operators + * that have been lexically analyzed as one operator. + */ +nodeptr multiunary(op, loc_model, oprnd) +nodeptr loc_model; +char *op; +nodeptr oprnd; + { + int n; + nodeptr nd; + + if (*op == '\0') + return oprnd; + for (n = 0; optab[n].tok.t_word != NULL; ++n) + if ((optab[n].expected & Unary) & (*(optab[n].tok.t_word) == *op)) { + nd = OpNode(n); + nd->n_file = loc_model->n_file; + nd->n_line = loc_model->n_line; + nd->n_col = loc_model->n_col; + return unary_nd(nd,multiunary(++op,loc_model,oprnd)); + } + fprintf(stderr, "compiler error: inconsistent parsing of unary operators"); + exit(EXIT_FAILURE); + } + +/* + * binary_nd - construct a node for a binary operator. + */ +nodeptr binary_nd(op, arg1, arg2) +nodeptr op; +nodeptr arg1; +nodeptr arg2; + { + register nodeptr t; + struct implement *impl; + + /* + * Find the data base entry for the operator. + */ + impl = optab[Val0(op)].binary; + if (impl == NULL) + nfatal(op, "binary operator not implemented", optab[Val0(op)].tok.t_word); + else if (impl->in_line == NULL) + nfatal(op, "binary operator not installed", optab[Val0(op)].tok.t_word); + + t = NewNode(4); + t->n_type = N_InvOp; + t->n_file = op->n_file; + t->n_line = op->n_line; + t->n_col = op->n_col; + t->freetmp = NULL; + t->n_field[0].n_val = 2; /* number of arguments */ + t->n_field[1].ip = impl; + t->n_field[2].n_ptr = arg1; + t->n_field[3].n_ptr = arg2; + return t; + } + +/* + * unary_nd - construct a node for a unary operator. + */ +nodeptr unary_nd(op, arg) +nodeptr op; +nodeptr arg; + { + register nodeptr t; + struct implement *impl; + + /* + * Find the data base entry for the operator. + */ + impl = optab[Val0(op)].unary; + if (impl == NULL) + nfatal(op, "unary operator not implemented", optab[Val0(op)].tok.t_word); + else if (impl->in_line == NULL) + nfatal(op, "unary operator not installed", optab[Val0(op)].tok.t_word); + + t = NewNode(3); + t->n_type = N_InvOp; + t->n_file = op->n_file; + t->n_line = op->n_line; + t->n_col = op->n_col; + t->freetmp = NULL; + t->n_field[0].n_val = 1; /* number of arguments */ + t->n_field[1].ip = impl; + t->n_field[2].n_ptr = arg; + return t; + } + +/* + * buildarray - convert "multi-dimensional" subscripting into a sequence + * of subsripting operations. + */ +nodeptr buildarray(a,lb,e) +nodeptr a, lb, e; + { + register nodeptr t, t2; + if (e->n_type == N_Elist) { + t2 = int_leaf(lb->n_type, lb, lb->n_field[0].n_val); + t = subsc_nd(t2, buildarray(a,lb,e->n_field[0].n_ptr), + e->n_field[1].n_ptr); + free(e); + } + else + t = subsc_nd(lb, a, e); + return t; + } + +/* + * subsc_nd - construct a node for subscripting. + */ +static nodeptr subsc_nd(op, arg1, arg2) +nodeptr op; +nodeptr arg1; +nodeptr arg2; + { + register nodeptr t; + struct implement *impl; + + /* + * Find the data base entry for subscripting. + */ + impl = spec_op[SubscOp]; + if (impl == NULL) + nfatal(op, "subscripting not implemented", NULL); + else if (impl->in_line == NULL) + nfatal(op, "subscripting not installed", NULL); + + t = NewNode(4); + t->n_type = N_InvOp; + t->n_file = op->n_file; + t->n_line = op->n_line; + t->n_col = op->n_col; + t->freetmp = NULL; + t->n_field[0].n_val = 2; /* number of arguments */ + t->n_field[1].ip = impl; + t->n_field[2].n_ptr = arg1; + t->n_field[3].n_ptr = arg2; + return t; + } + +/* + * to_nd - construct a node for binary to. + */ +nodeptr to_nd(op, arg1, arg2) +nodeptr op; +nodeptr arg1; +nodeptr arg2; + { + register nodeptr t; + struct implement *impl; + + /* + * Find the data base entry for to. + */ + impl = spec_op[ToOp]; + if (impl == NULL) + nfatal(op, "'i to j' not implemented", NULL); + else if (impl->in_line == NULL) + nfatal(op, "'i to j' not installed", NULL); + + t = NewNode(4); + t->n_type = N_InvOp; + t->n_file = op->n_file; + t->n_line = op->n_line; + t->n_col = op->n_col; + t->freetmp = NULL; + t->n_field[0].n_val = 2; /* number of arguments */ + t->n_field[1].ip = impl; + t->n_field[2].n_ptr = arg1; + t->n_field[3].n_ptr = arg2; + return t; + } + +/* + * toby_nd - construct a node for binary to-by. + */ +nodeptr toby_nd(op, arg1, arg2, arg3) +nodeptr op; +nodeptr arg1; +nodeptr arg2; +nodeptr arg3; + { + register nodeptr t; + struct implement *impl; + + /* + * Find the data base entry for to-by. + */ + impl = spec_op[ToByOp]; + if (impl == NULL) + nfatal(op, "'i to j by k' not implemented", NULL); + else if (impl->in_line == NULL) + nfatal(op, "'i to j by k' not installed", NULL); + + t = NewNode(5); + t->n_type = N_InvOp; + t->n_file = op->n_file; + t->n_line = op->n_line; + t->n_col = op->n_col; + t->freetmp = NULL; + t->n_field[0].n_val = 3; /* number of arguments */ + t->n_field[1].ip = impl; + t->n_field[2].n_ptr = arg1; + t->n_field[3].n_ptr = arg2; + t->n_field[4].n_ptr = arg3; + return t; + } + +/* + * aug_nd - create a node for an augmented assignment. + */ +nodeptr aug_nd(op, arg1, arg2) +nodeptr op; +nodeptr arg1; +nodeptr arg2; + { + register nodeptr t; + struct implement *impl; + + t = NewNode(5); + t->n_type = N_Augop; + t->n_file = op->n_file; + t->n_line = op->n_line; + t->n_col = op->n_col; + t->freetmp = NULL; + + /* + * Find the data base entry for assignment. + */ + impl = optab[asgn_loc].binary; + if (impl == NULL) + nfatal(op, "assignment not implemented", NULL); + t->n_field[0].ip = impl; + + /* + * The operator table entry for the augmented assignment is + * immediately after the entry for the operation. + */ + impl = optab[Val0(op) - 1].binary; + if (impl == NULL) + nfatal(op, "binary operator not implemented", + optab[Val0(op) - 1].tok.t_word); + t->n_field[1].ip = impl; + + t->n_field[2].n_ptr = arg1; + t->n_field[3].n_ptr = arg2; + /* t->n_field[4].typ - type of intermediate result */ + return t; + } + +/* + * sect_nd - create a node for sectioning. + */ +nodeptr sect_nd(op, arg1, arg2, arg3) +nodeptr op; +nodeptr arg1; +nodeptr arg2; +nodeptr arg3; + { + register nodeptr t; + int tok; + struct implement *impl; + struct implement *impl1; + + t = NewNode(5); + t->n_file = op->n_file; + t->n_line = op->n_line; + t->n_col = op->n_col; + t->freetmp = NULL; + + /* + * Find the data base entry for sectioning. + */ + impl = spec_op[SectOp]; + if (impl == NULL) + nfatal(op, "sectioning not implemented", NULL); + + tok = optab[Val0(op)].tok.t_type; + if (tok == COLON) { + /* + * Simple sectioning, treat as a ternary operator. + */ + t->n_type = N_InvOp; + t->n_field[0].n_val = 3; /* number of arguments */ + t->n_field[1].ip = impl; + } + else { + /* + * Find the data base entry for addition or subtraction. + */ + if (tok == PCOLON) { + impl1 = optab[plus_loc].binary; + if (impl1 == NULL) + nfatal(op, "addition not implemented", NULL); + } + else { /* MCOLON */ + impl1 = optab[minus_loc].binary; + if (impl1 == NULL) + nfatal(op, "subtraction not implemented", NULL); + } + t->n_type = N_Sect; + t->n_field[0].ip = impl; + t->n_field[1].ip = impl1; + } + t->n_field[2].n_ptr = arg1; + t->n_field[3].n_ptr = arg2; + t->n_field[4].n_ptr = arg3; + return t; + } + +/* + * invk_main - produce an procedure invocation node with one argument for + * use in the initial invocation to main() during type inference. + */ +nodeptr invk_main(main_proc) +struct pentry *main_proc; + { + register nodeptr t; + + t = NewNode(3); + t->n_type = N_InvProc; + t->n_file = NULL; + t->n_line = 0; + t->n_col = 0; + t->freetmp = NULL; + t->n_field[0].n_val = 1; /* 1 argument */ + t->n_field[1].proc = main_proc; + t->n_field[2].n_ptr = tree1(N_Empty); + + if (max_prm < 1) + max_prm = 1; + return t; + } diff --git a/src/iconc/ctree.h b/src/iconc/ctree.h new file mode 100644 index 0000000..d38d3c4 --- /dev/null +++ b/src/iconc/ctree.h @@ -0,0 +1,200 @@ +/* + * Structure of a tree node. + */ + +typedef struct node *nodeptr; + +/* + * Kinds of fields in syntax tree node. + */ +union field { + long n_val; /* integer-valued fields */ + char *n_str; /* string-valued fields */ + struct lentry *lsym; /* fields referencing local symbol table entries */ + struct centry *csym; /* fields referencing constant symbol table entries */ + struct implement *ip; /* fields referencing an operation */ + struct pentry *proc; /* pointer to procedure entry */ + struct rentry *rec; /* pointer to record entry */ +#ifdef OptimizeType + struct typinfo *typ; /* extra type field */ +#else /* OptimizeType */ + unsigned int *typ; /* extra type field */ +#endif /* OptimizeType */ + nodeptr n_ptr; /* subtree pointers */ + }; + +/* + * A store is an array that maps variables types (which are given indexes) + * to the types stored within the variables. + */ +struct store { + struct store *next; + int perm; /* flag: whether store stays across iterations */ +#ifdef OptimizeType + struct typinfo *types[1]; /* actual size is number of variables */ +#else /* OptimizeType */ + unsigned int *types[1]; /* actual size is number of variables */ +#endif /* OptimizeType */ + }; + +/* + * Array of parameter types for an operation call. + */ +struct symtyps { + int nsyms; /* number of parameter symbols */ + struct symtyps *next; +#ifdef OptimizeType + struct typinfo *types[1]; /* really one for every symbol */ +#else /* OptimizeType */ + unsigned int *types[1]; /* really one for every symbol */ +#endif /* OptimizeType */ + }; + +/* + * definitions for maintaining allocation status. + */ +#define NotAlloc 0 /* temp var neither in use nor reserved */ +#define InUnse 1 /* temp var currently contains live variable */ +/* n < 0 reserved: must be free by node with postn field = n */ + +#define DescTmp 1 /* allocation of descriptor temporary */ +#define CIntTmp 2 /* allocation of C integer temporary */ +#define CDblTmp 3 /* allocation of C double temporary */ +#define SBuf 4 /* allocation of string buffer */ +#define CBuf 5 /* allocation of cset buffer */ + +struct freetmp { /* list of things to free at a node */ + int kind; /* DescTmp, CIntTmp, CDblTmp, SBuf, or CBuf */ + int indx; /* index into status array */ + int old; /* old status */ + struct freetmp *next; + }; + +struct node { + int n_type; /* node type */ + char *n_file; /* name of file containing source program */ + int n_line; /* line number in source program */ + int n_col; /* column number in source program */ + int flag; + int *new_types; /* pntr to array of struct types created here */ +#ifdef OptimizeType + struct typinfo *type; /* type of this expression */ +#else /* OptimizeType */ + unsigned int *type; /* type of this expression */ +#endif /* OptimizeType */ + struct store *store; /* if needed, store saved between iterations */ + struct symtyps *symtyps; /* for operation in data base: types of arg syms */ + nodeptr lifetime; /* lifetime of intermediate result */ + int reuse; /* result may be reused without being recomputed */ + nodeptr intrnl_lftm; /* lifetime of variables internal to operation */ + int postn; /* relative position of node in execution order */ + struct freetmp *freetmp; /* temporary variables to free at this point */ + union field n_field[1]; /* node fields */ + }; + +/* + * NewNode - allocate a parse tree node with "size" fields. + */ +#define NewNode(size) (struct node *)alloc((unsigned int)\ + (sizeof(struct node) + (size-1) * sizeof(union field))) + +/* + * Macros to access fields of parse tree nodes. + */ + +#define Type(t) t->n_type +#define File(t) t->n_file +#define Line(t) t->n_line +#define Col(t) t->n_col +#define Tree0(t) t->n_field[0].n_ptr +#define Tree1(t) t->n_field[1].n_ptr +#define Tree2(t) t->n_field[2].n_ptr +#define Tree3(t) t->n_field[3].n_ptr +#define Tree4(t) t->n_field[4].n_ptr +#define Val0(t) t->n_field[0].n_val +#define Val1(t) t->n_field[1].n_val +#define Val2(t) t->n_field[2].n_val +#define Val3(t) t->n_field[3].n_val +#define Val4(t) t->n_field[4].n_val +#define Str0(t) t->n_field[0].n_str +#define Str1(t) t->n_field[1].n_str +#define Str2(t) t->n_field[2].n_str +#define Str3(t) t->n_field[3].n_str +#define LSym0(t) t->n_field[0].lsym +#define CSym0(t) t->n_field[0].csym +#define Impl0(t) t->n_field[0].ip +#define Impl1(t) t->n_field[1].ip +#define Rec1(t) t->n_field[1].rec +#define Proc1(t) t->n_field[1].proc +#define Typ4(t) t->n_field[4].typ + +/* + * External declarations. + */ + +extern nodeptr yylval; /* parser's current token value */ +extern struct node tok_loc; /* "model" token holding current location */ + +/* + * Node types. + */ + +#define N_Activat 1 /* activation control structure */ +#define N_Alt 2 /* alternation operator */ +#define N_Apply 3 /* procedure application */ +#define N_Augop 4 /* augmented operator */ +#define N_Bar 5 /* generator control structure */ +#define N_Break 6 /* break statement */ +#define N_Case 7 /* case statement */ +#define N_Ccls 8 /* case clause */ +#define N_Clist 9 /* list of case clauses */ +#define N_Create 10 /* create control structure */ +#define N_Cset 11 /* cset literal */ +#define N_Elist 12 /* list of expressions */ +#define N_Empty 13 /* empty expression or statement */ +#define N_Field 14 /* record field reference */ +#define N_Id 15 /* identifier token */ +#define N_If 16 /* if-then-else statement */ +#define N_Int 17 /* integer literal */ +#define N_Invok 18 /* invocation */ +#define N_InvOp 19 /* invoke operation */ +#define N_InvProc 20 /* invoke operation */ +#define N_InvRec 21 /* invoke operation */ +#define N_Limit 22 /* LIMIT control structure */ +#define N_Loop 23 /* while, until, every, or repeat */ +#define N_Next 24 /* next statement */ +#define N_Not 25 /* not prefix control structure */ +#define N_Op 26 /* operator token */ +#define N_Proc 27 /* procedure */ +#define N_Real 28 /* real literal */ +#define N_Res 29 /* reserved word token */ +#define N_Ret 30 /* fail, return, or succeed */ +#define N_Scan 31 /* scan-using statement */ +#define N_Sect 32 /* s[i:j] (section) */ +#define N_Slist 33 /* list of statements */ +#define N_Str 34 /* string literal */ +#define N_SmplAsgn 35 /* simple assignment to named var */ +#define N_SmplAug 36 /* simple assignment to named var */ + +#define AsgnDirect 0 /* rhs of special := can compute directly into var */ +#define AsgnCopy 1 /* special := must copy result into var */ +#define AsgnDeref 2 /* special := must dereference result into var */ + + +/* + * Macros for constructing basic nodes. + */ + +#define CsetNode(a,b) i_str_leaf(N_Cset,&tok_loc,a,b) +#define IdNode(a) c_str_leaf(N_Id,&tok_loc,a) +#define IntNode(a) c_str_leaf(N_Int,&tok_loc,a) +#define OpNode(a) int_leaf(N_Op,&tok_loc,a) +#define RealNode(a) c_str_leaf(N_Real,&tok_loc,a) +#define ResNode(a) int_leaf(N_Res,&tok_loc,a) +#define StrNode(a,b) i_str_leaf(N_Str,&tok_loc,a,b) + +/* + * MultiUnary - create subtree from an operator symbol that represents + * multiple unary operators. + */ +#define MultiUnary(a,b) multiunary(optab[Val0(a)].tok.t_word, a, b) diff --git a/src/iconc/dbase.c b/src/iconc/dbase.c new file mode 100644 index 0000000..fdd3e50 --- /dev/null +++ b/src/iconc/dbase.c @@ -0,0 +1,196 @@ +/* + * dbase.c - routines to access data base of implementation information + * produced by rtt. + */ +#include "../h/gsupport.h" +#include "../h/lexdef.h" +#include "ctrans.h" +#include "csym.h" +#include "ctree.h" +#include "ccode.h" +#include "cproto.h" +#include "cglobals.h" + +/* + * Prototypes. + */ +static int chck_spec (struct implement *ip); +static int acpt_op (struct implement *ip); + + +static struct optab *optr; /* pointer into operator table */ + +/* + * readdb - read data base produced by rtt. + */ +void readdb(db_name) +char *db_name; + { + char *op, *s; + int i; + struct implement *ip; + char buf[MaxPath]; /* file name construction buffer */ + struct fileparts *fp; + unsigned hashval; + + fp = fparse(db_name); + if (*fp->ext == '\0') + db_name = salloc(makename(buf, NULL, db_name, DBSuffix)); + else if (!smatch(fp->ext, DBSuffix)) + quitf("bad data base name: %s", db_name); + + if (!db_open(db_name, &s)) + db_err1(1, "cannot open data base"); + + if (largeints && (*s == 'N')) { + twarn("Warning, run-time system does not support large integers", NULL); + largeints = 0; + } + + /* + * Read information about functions. + */ + db_tbl("functions", bhash); + + /* + * Read information about operators. + */ + optr = optab; + + /* + * read past operators header. + */ + db_chstr("operators", "operators"); + + while ((op = db_string()) != NULL) { + if ((ip = db_impl('O')) == NULL) + db_err2(1, "no implementation information for operator", op); + ip->op = op; + if (acpt_op(ip)) { + db_code(ip); + hashval = IHasher(op); + ip->blink = ohash[hashval]; + ohash[hashval] = ip; + db_chstr("end", "end"); + } + else + db_dscrd(ip); + } + db_chstr("endsect", "endsect"); + + /* + * Read information about keywords. + */ + db_tbl("keywords", khash); + + db_close(); + + /* + * If error conversion is supported, make sure it is reflected in + * the minimum result sequence of operations. + */ + if (err_conv) { + for (i = 0; i < IHSize; ++i) + for (ip = bhash[i]; ip != NULL; ip = ip->blink) + if (ip->ret_flag & DoesEFail) + ip->min_result = 0; + for (i = 0; i < IHSize; ++i) + for (ip = ohash[i]; ip != NULL; ip = ip->blink) + if (ip->ret_flag & DoesEFail) + ip->min_result = 0; + for (i = 0; i < IHSize; ++i) + for (ip = khash[i]; ip != NULL; ip = ip->blink) + if (ip->ret_flag & DoesEFail) + ip->min_result = 0; + } + } + +/* + * acpt_opt - given a data base entry for an operator determine if it + * is in iconc's operator table. + */ +static int acpt_op(ip) +struct implement *ip; + { + register char *op; + register int opcmp; + + /* + * Calls to this function are in lexical order by operator symbol continue + * searching operator table from where we left off. + */ + op = ip->op; + for (;;) { + /* + * optab has augmented assignments out of lexical order. Skip anything + * which does not expect an implementation. This gets augmented + * assignments out of the way. + */ + while (optr->expected == 0 && optr->tok.t_word != NULL) + ++optr; + if (optr->tok.t_word == NULL) + return chck_spec(ip); + opcmp = strcmp(op, optr->tok.t_word); + if (opcmp > 0) + ++optr; + else if (opcmp < 0) + return chck_spec(ip); + else { + if (ip->nargs == 1 && (optr->expected & Unary)) { + if (optr->unary == NULL) { + optr->unary = ip; + return 1; + } + else + return 0; + } + else if (ip->nargs == 2 && (optr->expected & Binary)) { + if (optr->binary == NULL) { + optr->binary = ip; + return 1; + } + else + return 0; + } + else + return chck_spec(ip); + } + } + } + +/* + * chck_spec - check whether the operator is one that does not use standard + * unary or binary syntax. + */ +static int chck_spec(ip) +struct implement *ip; + { + register char *op; + int indx; + + indx = -1; + op = ip->op; + if (strcmp(op, "...") == 0) { + if (ip->nargs == 2) + indx = ToOp; + else + indx = ToByOp; + } + else if (strcmp(op, "[:]") == 0) + indx = SectOp; + else if (strcmp(op, "[]") == 0) + indx = SubscOp; + else if (strcmp(op, "[...]") == 0) + indx = ListOp; + + if (indx == -1) { + db_err2(0, "unexpected operator (or arity),", op); + return 0; + } + if (spec_op[indx] == NULL) { + spec_op[indx] = ip; + return 1; + } + else + return 0; + } diff --git a/src/iconc/fixcode.c b/src/iconc/fixcode.c new file mode 100644 index 0000000..b8c06e0 --- /dev/null +++ b/src/iconc/fixcode.c @@ -0,0 +1,372 @@ +/* + * fixcode.c - routines to "fix code" by determining what signals are returned + * by continuations and what must be done when they are. Also perform + * optional control flow optimizations. + */ +#include "../h/gsupport.h" +#include "ctrans.h" +#include "cglobals.h" +#include "ccode.h" +#include "ctree.h" +#include "csym.h" +#include "cproto.h" + +/* + * Prototypes for static functions. + */ +static struct code *ck_unneed (struct code *cd, struct code *lbl); +static void clps_brch (struct code *branch); +static void dec_refs (struct code *cd); +static void rm_unrch (struct code *cd); + +/* + * fix_fncs - go through the generated C functions, determine how calls + * handle signals, in-line trivial functions where possible, remove + * goto's which immediately precede their labels, and remove unreachable + * code. + */ +void fix_fncs(fnc) +struct c_fnc *fnc; + { + struct code *cd, *cd1; + struct code *contbody; + struct sig_act *sa; + struct sig_lst *sl; + struct code *call; + struct code *create; + struct code *ret_sig; + struct code *sig; + struct c_fnc *calledcont; + int no_break; + int collapse; + + /* + * Fix any called functions and decide how the calls handle the + * returned signals. + */ + fnc->flag |= CF_Mark; + for (call = fnc->call_lst; call != NULL; call = call->NextCall) { + calledcont = call->Cont; + if (calledcont != NULL) { + if (!(calledcont->flag & CF_Mark)) + fix_fncs(calledcont); + if (calledcont->flag & CF_ForeignSig) { + call->Flags |= ForeignSig; + fnc->flag |= CF_ForeignSig; + } + } + + + /* + * Try to collapse call chains of continuations. + */ + if (opt_cntrl && calledcont != NULL) { + contbody = calledcont->cd.next; + if (call->OperName == NULL && contbody->cd_id == C_RetSig) { + /* + * A direct call of a continuation which consists of just a + * return. Replace call with code to handle the returned signal. + */ + ret_sig = contbody->SigRef->sig; + if (ret_sig == &resume) + cd1 = sig_cd(call->ContFail, fnc); + else + cd1 = sig_cd(ret_sig, fnc); + cd1->prev = call->prev; + cd1->prev->next = cd1; + cd1->next = call->next; + if (cd1->next != NULL) + cd1->next->prev = cd1; + --calledcont->ref_cnt; + continue; /* move on to next call */ + } + else if (contbody->cd_id == C_CallSig && contbody->next == NULL) { + /* + * The called continuation contains only a call. + */ + if (call->OperName == NULL) { + /* + * We call the continuation directly, so we can in-line it. + * We must replace signal returns with appropriate actions. + */ + if (--calledcont->ref_cnt != 0 && contbody->Cont != NULL) + ++contbody->Cont->ref_cnt; + call->OperName = contbody->OperName; + call->ArgLst = contbody->ArgLst; + call->Cont = contbody->Cont; + call->Flags = contbody->Flags; + for (sa = contbody->SigActs; sa != NULL; sa = sa->next) { + ret_sig = sa->cd->SigRef->sig; + if (ret_sig == &resume) + cd1 = sig_cd(call->ContFail, fnc); + else + cd1 = sig_cd(ret_sig, fnc); + call->SigActs = new_sgact(sa->sig, cd1, call->SigActs); + } + continue; /* move on to next call */ + } + else if (contbody->OperName == NULL) { + /* + * The continuation simply calls another continuation. We can + * eliminate the intermediate continuation as long as we can + * move signal conversions to the other side of the operation. + * The operation only intercepts resume signals. + */ + collapse = 1; + for (sa = contbody->SigActs; sa != NULL; sa = sa->next) { + ret_sig = sa->cd->SigRef->sig; + if (sa->sig != ret_sig && (sa->sig == &resume || + ret_sig == &resume)) + collapse = 0; + } + if (collapse) { + if (--calledcont->ref_cnt != 0 && contbody->Cont != NULL) + ++contbody->Cont->ref_cnt; + call->Cont = contbody->Cont; + for (sa = contbody->SigActs; sa != NULL; sa = sa->next) { + ret_sig = sa->cd->SigRef->sig; + if (ret_sig != &resume) + call->SigActs = new_sgact(sa->sig, sig_cd(ret_sig, fnc), + call->SigActs); + } + continue; /* move on to next call */ + } + } + } + } + + /* + * We didn't do any optimizations. We must still figure out + * out how to handle signals returned by the continuation. + */ + if (calledcont != NULL) { + for (sl = calledcont->sig_lst; sl != NULL; sl = sl->next) { + if (sl->ref_cnt > 0) { + sig = sl->sig; + /* + * If an operation is being called, it handles failure from the + * continuation. + */ + if (sig != &resume || call->OperName == NULL) { + if (sig == &resume) + cd1 = sig_cd(call->ContFail, fnc); + else + cd1 = sig_cd(sig, fnc); + call->SigActs = new_sgact(sig, cd1, call->SigActs); + } + } + } + } + } + + /* + * fix up the signal handling in the functions implementing co-expressions. + */ + for (create = fnc->creatlst; create != NULL; create = create->NextCreat) + fix_fncs(create->Cont); + + if (!opt_cntrl) + return; /* control flow optimizations disabled. */ + /* + * Collapse branch chains and remove unreachable code. + */ + for (cd = &(fnc->cd); cd != NULL; cd = cd->next) { + switch (cd->cd_id) { + case C_CallSig: + no_break = 1; + for (sa = cd->SigActs; sa != NULL; sa = sa->next) { + if (sa->cd->cd_id == C_Break) { + switch (cd->next->cd_id) { + case C_Goto: + sa->cd->cd_id = cd->next->cd_id; + sa->cd->Lbl = cd->next->Lbl; + ++sa->cd->Lbl->RefCnt; + break; + case C_RetSig: + sa->cd->cd_id = cd->next->cd_id; + sa->cd->SigRef= cd->next->SigRef; + ++sa->cd->SigRef->ref_cnt; + break; + default: + no_break = 0; + } + } + if (sa->cd->cd_id == C_Goto) + clps_brch(sa->cd); + } + if (no_break) + rm_unrch(cd); + /* + * Try converting gotos into breaks. + */ + for (sa = cd->SigActs; sa != NULL; sa = sa->next) + if (sa->cd->cd_id == C_Goto) { + cd1 = cd->next; + while (cd1 != NULL && (cd1->cd_id == C_Label || + cd1->cd_id == C_RBrack)) { + if (cd1 == sa->cd->Lbl) { + sa->cd->cd_id = C_Break; + --cd1->RefCnt; + break; + } + cd1 = cd1->next; + } + } + break; + + case C_Goto: + clps_brch(cd); + rm_unrch(cd); + if (cd->cd_id == C_Goto) + ck_unneed(cd, cd->Lbl); + break; + + case C_If: + if (cd->ThenStmt->cd_id == C_Goto) { + clps_brch(cd->ThenStmt); + if (cd->ThenStmt->cd_id == C_Goto) + ck_unneed(cd, cd->ThenStmt->Lbl); + } + break; + + case C_PFail: + case C_PRet: + case C_RetSig: + rm_unrch(cd); + break; + } + } + + /* + * If this function only contains a return, indicate that we can + * call a shared signal returning function instead of it. This is + * a special case of "common subROUTINE elimination". + */ + if (fnc->cd.next->cd_id == C_RetSig) + fnc->flag |= CF_SigOnly; + } + +/* + * clps_brch - collapse branch chains. + */ +static void clps_brch(branch) +struct code *branch; + { + struct code *cd; + int save_id; + + cd = branch->Lbl->next; + while (cd->cd_id == C_Label) + cd = cd->next; + + /* + * Avoid infinite recursion on empty infinite loops. + */ + save_id = branch->cd_id; + branch->cd_id = 0; + if (cd->cd_id == C_Goto) + clps_brch(cd); + branch->cd_id = save_id; + + switch (cd->cd_id) { + case C_Goto: + --branch->Lbl->RefCnt; + ++cd->Lbl->RefCnt; + branch->Lbl = cd->Lbl; + break; + case C_RetSig: + /* + * This optimization requires that C_Goto have as many fields + * as C_RetSig. + */ + --branch->Lbl->RefCnt; + ++cd->SigRef->ref_cnt; + branch->cd_id = C_RetSig; + branch->SigRef = cd->SigRef; + break; + } + } + +/* + * rm_unrch - any code after the given point up to the next label is + * unreachable. Remove it. + */ +static void rm_unrch(cd) +struct code *cd; + { + struct code *cd1; + + for (cd1 = cd->next; cd1 != NULL && cd1->cd_id != C_LBrack && + (cd1->cd_id != C_Label || cd1->RefCnt == 0); cd1 = cd1->next) { + if (cd1->cd_id == C_RBrack) { + /* + * Continue deleting past a '}', but don't delete the '}' itself. + */ + cd->next = cd1; + cd1->prev = cd; + cd = cd1; + } + else + dec_refs(cd1); + } + cd->next = cd1; + if (cd1 != NULL) + cd1->prev = cd; + } + +/* + * dec_refs - decrement reference counts for things this code references. + */ +static void dec_refs(cd) +struct code *cd; + { + struct sig_act *sa; + + if (cd == NULL) + return; + switch (cd->cd_id) { + case C_Goto: + --cd->Lbl->RefCnt; + return; + case C_RetSig: + --cd->SigRef->ref_cnt; + return; + case C_CallSig: + if (cd->Cont != NULL) + --cd->Cont->ref_cnt; + for (sa = cd->SigActs; sa != NULL; sa = sa->next) + dec_refs(sa->cd); + return; + case C_If: + dec_refs(cd->ThenStmt); + return; + case C_Create: + --cd->Cont->ref_cnt; + return; + } + } + +/* + * ck_unneed - if there is nothing between a goto and its label, except + * perhaps other labels or '}', it is useless, so remove it. + */ +static struct code *ck_unneed(cd, lbl) +struct code *cd; +struct code *lbl; + { + struct code *cd1; + + cd1 = cd->next; + while (cd1 != NULL && (cd1->cd_id == C_Label || cd1->cd_id == C_RBrack)) { + if (cd1 == lbl) { + cd = cd->prev; + cd->next = cd->next->next; + cd->next->prev = cd; + --lbl->RefCnt; + break; + } + cd1 = cd1->next; + } + return cd; + } + diff --git a/src/iconc/incheck.c b/src/iconc/incheck.c new file mode 100644 index 0000000..d4110f9 --- /dev/null +++ b/src/iconc/incheck.c @@ -0,0 +1,802 @@ +/* + * incheck.c - analyze a run-time operation using type information. + * Determine wither the operation can be in-lined and what kinds + * of parameter passing optimizations can be done. + */ +#include "../h/gsupport.h" +#include "ctrans.h" +#include "cglobals.h" +#include "csym.h" +#include "ctree.h" +#include "ccode.h" +#include "cproto.h" + +struct op_symentry *cur_symtab; /* symbol table for current operation */ + +/* + * Prototypes for static functions. + */ +static struct code *and_cond (struct code *cd1, struct code *cd2); +static int cnv_anlz (unsigned int typcd, struct il_code *src, + struct il_c *dflt, struct il_c *dest, + struct code **cdp); +static int defer_il (struct il_code *il); +static int if_anlz (struct il_code *il); +static void ilc_anlz (struct il_c *ilc); +static int il_anlz (struct il_code *il); +static void ret_anlz (struct il_c *ilc); +static int tc_anlz (struct il_code *il, int has_dflt); + +static int n_branches; /* number branches caused by run-time type checking */ +static int side_effect; /* abstract clause indicates side-effect */ +static int n_vararg; /* size of variable part of arg list to operation */ +static int n_susp; /* number of suspends */ +static int n_ret; /* number of returns */ + +/* + * do_inlin - determine if this operation can be in-lined at the current + * invocation. Also gather information about how arguments are used, + * and determine where the success continuation for the operation + * should be put. + */ +int do_inlin(impl, n, cont_loc, symtab, n_va) +struct implement *impl; +nodeptr n; +int *cont_loc; +struct op_symentry *symtab; +int n_va; + { + int nsyms; + int i; + + /* + * Copy arguments needed by other functions into globals and + * initialize flags and counters for information to be gathered + * during analysis. + */ + cur_symtyps = n->symtyps; /* mapping from arguments to types */ + cur_symtab = symtab; /* parameter info to be filled in */ + n_vararg = n_va; + n_branches = 0; + side_effect = 0; + n_susp = 0; + n_ret = 0; + + /* + * Analyze the code for this operation using type information for + * the arguments to the invocation. + */ + il_anlz(impl->in_line); + + + /* + * Don't in-line if there is more than one decision made based on + * run-time type checks (this is a heuristic). + */ + if (n_branches > 1) + return 0; + + /* + * If the operation (after eliminating code not used in this context) + * has one suspend and no returns, the "success continuation" can + * be placed in-line at the suspend site. Otherwise, any suspends + * require a separate function for the continuation. + */ + if (n_susp == 1 && n_ret == 0) + *cont_loc = SContIL; /* in-line continuation */ + else if (n_susp > 0) + *cont_loc = SepFnc; /* separate function for continuation */ + else + *cont_loc = EndOper; /* place "continuation" after the operation */ + + /* + * When an argument at the source level is an Icon variable, it is + * sometimes safe to use it directly in the generated code as the + * argument to the operation. However, it is NOT safe under the + * following conditions: + * + * - if the operation modifies the argument. + * - if the operation suspends and resumes so that intervening + * changes to the variable would be visible as changes to the + * argument. + * - if the operation has side effects that might involve the + * variable and be visible as changes to the argument. + */ + nsyms = (cur_symtyps == NULL ? 0 : cur_symtyps->nsyms); + for (i = 0; i < nsyms; ++i) + if (symtab[i].n_mods == 0 && n->intrnl_lftm == n && !side_effect) + symtab[i].var_safe = 1; + + return 1; + } + +/* + * il_anlz - analyze a piece of RTL code. Return an indication of + * whether execution can continue beyond it. + */ +static int il_anlz(il) +struct il_code *il; + { + int fall_thru; + int ncases; + int condition; + int indx; + int i, j; + + if (il == NULL) + return 1; + + switch (il->il_type) { + case IL_Const: /* should have been replaced by literal node */ + return 1; + + case IL_If1: + /* + * if-then statement. Determine whether the condition may + * succeed or fail. Analyze the then clause if needed. + */ + condition = if_anlz(il->u[0].fld); + fall_thru = 0; + if (condition & MaybeTrue) + fall_thru |= il_anlz(il->u[1].fld); + if (condition & MaybeFalse) + fall_thru = 1; + return fall_thru; + + case IL_If2: + /* + * if-then-else statement. Determine whether the condition may + * succeed or fail. Analyze the "then" clause and the "else" + * clause if needed. + */ + condition = if_anlz(il->u[0].fld); + fall_thru = 0; + if (condition & MaybeTrue) + fall_thru |= il_anlz(il->u[1].fld); + if (condition & MaybeFalse) + fall_thru |= il_anlz(il->u[2].fld); + return fall_thru; + + case IL_Tcase1: + /* + * type_case statement with no default clause. + */ + return tc_anlz(il, 0); + + case IL_Tcase2: + /* + * type_case statement with a default clause. + */ + return tc_anlz(il, 1); + + case IL_Lcase: + /* + * len_case statement. Determine which case matches the number + * of arguments. + */ + ncases = il->u[0].n; + indx = 1; + for (i = 0; i < ncases; ++i) { + if (il->u[indx++].n == n_vararg) /* selection number */ + return il_anlz(il->u[indx].fld); /* action */ + ++indx; + } + return il_anlz(il->u[indx].fld); /* default */ + + case IL_Acase: { + /* + * arith_case statement. + */ + struct il_code *var1; + struct il_code *var2; + int maybe_int; + int maybe_dbl; + int chk1; + int chk2; + + var1 = il->u[0].fld; + var2 = il->u[1].fld; + arth_anlz(var1, var2, &maybe_int, &maybe_dbl, &chk1, NULL, + &chk2, NULL); + + /* + * Analyze the selected case (note, large integer code is not + * currently in-lined and can be ignored). + */ + fall_thru = 0; + if (maybe_int) + fall_thru |= il_anlz(il->u[2].fld); /* C_integer action */ + if (maybe_dbl) + fall_thru |= il_anlz(il->u[4].fld); /* C_double action */ + return fall_thru; + } + + case IL_Err1: + /* + * runerr() with no offending value. + */ + return 0; + + case IL_Err2: + /* + * runerr() with an offending value. Note the reference to + * the offending value descriptor. + */ + indx = il->u[1].fld->u[0].n; /* symbol table index of variable */ + if (indx < cur_symtyps->nsyms) + ++cur_symtab[indx].n_refs; + return 0; + + case IL_Block: + /* + * inline {...} statement. + */ + i = il->u[1].n + 2; /* skip declaration stuff */ + ilc_anlz(il->u[i].c_cd); /* body of block */ + return il->u[0].n; + + case IL_Call: + /* + * call to body function. + */ + if (il->u[3].n & DoesSusp) + n_susp = 2; /* force continuation into separate function */ + + /* + * Analyze the C code for prototype parameter declarations + * and actual arguments. There are twice as many pieces of + * C code to look at as there are parameters. + */ + j = 2 * il->u[7].n; + i = 8; /* index of first piece of C code */ + while (j--) + ilc_anlz(il->u[i++].c_cd); + return ((il->u[3].n & DoesFThru) != 0); + + case IL_Lst: + /* + * Two consecutive pieces of RTL code. + */ + fall_thru = il_anlz(il->u[0].fld); + if (fall_thru) + fall_thru = il_anlz(il->u[1].fld); + return fall_thru; + + case IL_Abstr: + /* + * abstract type computation. See if it indicates side effects. + */ + if (il->u[0].fld != NULL) + side_effect = 1; + return 1; + + default: + fprintf(stderr, "compiler error: unknown info in data base\n"); + exit(EXIT_FAILURE); + /* NOTREACHED */ + } + } + +/* + * if_anlz - analyze the condition of an if statement. + */ +static int if_anlz(il) +struct il_code *il; + { + int cond; + int cond1; + + if (il->il_type == IL_Bang) { + /* + * ! , negate the result of the condition + */ + cond1 = cond_anlz(il->u[0].fld, NULL); + cond = 0; + if (cond1 & MaybeTrue) + cond = MaybeFalse; + if (cond1 & MaybeFalse) + cond |= MaybeTrue; + } + else + cond = cond_anlz(il, NULL); + if (cond == (MaybeTrue | MaybeFalse)) + ++n_branches; /* must make a run-time decision */ + return cond; + } + +/* + * cond_anlz - analyze a simple condition or the conjunction of two + * conditions. If cdp is not NULL, use it to return a pointer code + * that implements the condition. + */ +int cond_anlz(il, cdp) +struct il_code *il; +struct code **cdp; + { + struct code *cd1; + struct code *cd2; + int cond1; + int cond2; + int indx; + + switch (il->il_type) { + case IL_And: + /* + * && + */ + cond1 = cond_anlz(il->u[0].fld, (cdp == NULL ? NULL : &cd1)); + if (cond1 & MaybeTrue) { + cond2 = cond_anlz(il->u[1].fld, (cdp == NULL ? NULL : &cd2)); + if (cdp != NULL) { + if (!(cond2 & MaybeTrue)) + *cdp = NULL; + else + *cdp = and_cond(cd1, cd2); + } + return (cond1 & MaybeFalse) | cond2; + } + else { + if (cdp != NULL) + *cdp = cd1; + return cond1; + } + + case IL_Cnv1: + /* + * cnv:() + */ + return cnv_anlz(il->u[0].n, il->u[1].fld, NULL, NULL, cdp); + + case IL_Cnv2: + /* + * cnv:(,) + */ + return cnv_anlz(il->u[0].n, il->u[1].fld, NULL, il->u[2].c_cd, cdp); + + case IL_Def1: + /* + * def:(,) + */ + return cnv_anlz(il->u[0].n, il->u[1].fld, il->u[2].c_cd, NULL, cdp); + + case IL_Def2: + /* + * def:(,,) + */ + return cnv_anlz(il->u[0].n, il->u[1].fld, il->u[2].c_cd, il->u[3].c_cd, + cdp); + + case IL_Is: + /* + * is:() + */ + indx = il->u[1].fld->u[0].n; + cond1 = eval_is(il->u[0].n, indx); + if (cdp == NULL) { + if (indx < cur_symtyps->nsyms && cond1 == (MaybeTrue | MaybeFalse)) + ++cur_symtab[indx].n_refs; + } + else { + if (cond1 == (MaybeTrue | MaybeFalse)) + *cdp = typ_chk(il->u[1].fld, il->u[0].n); + else + *cdp = NULL; + } + return cond1; + + default: + fprintf(stderr, "compiler error: unknown info in data base\n"); + exit(EXIT_FAILURE); + /* NOTREACHED */ + } + } + + +/* + * and_cond - construct && of two conditions, either of which may have + * been optimized away. + */ +static struct code *and_cond(cd1, cd2) +struct code *cd1; +struct code *cd2; + { + struct code *cd; + + if (cd1 == NULL) + return cd2; + else if (cd2 == NULL) + return cd1; + else { + cd = alc_ary(3); + cd->ElemTyp(0) = A_Ary; + cd->Array(0) = cd1; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " && "; + cd->ElemTyp(2) = A_Ary; + cd->Array(2) = cd2; + return cd; + } + } + +/* + * cnv_anlz - analyze a type conversion. Determine whether it can succeed + * and, if requested, produce code to perform the conversion. Also + * gather information about the variables it uses. + */ +static int cnv_anlz(typcd, src, dflt, dest, cdp) +unsigned int typcd; +struct il_code *src; +struct il_c *dflt; +struct il_c *dest; +struct code **cdp; + { + struct val_loc *src_loc; + int cond; + int cnv_flags; + int indx; + + /* + * Find out what is going on in the default and destination subexpressions. + * (The information is used elsewhere.) + */ + ilc_anlz(dflt); + ilc_anlz(dest); + + if (cdp != NULL) + *cdp = NULL; /* clear code pointer in case it is not set below */ + + /* + * Determine whether the conversion may succeed, whether it may fail, + * and whether it may actually convert a value or use the default + * value when it succeeds. + */ + indx = src->u[0].n; /* symbol table index for source of conversion */ + cond = eval_cnv(typcd, indx, dflt != NULL, &cnv_flags); + + /* + * Many optimizations are possible depending on whether a conversion + * is actually needed, whether type checking is needed, whether defaulting + * is done, and whether there is an explicit destination. Several + * optimizations are performed here; more may be added in the future. + */ + if (!(cnv_flags & MayDefault)) + dflt = NULL; /* demote defaulting to simple conversion */ + + if (cond & MaybeTrue) { + if (cnv_flags == MayKeep && dest == NULL) { + /* + * No type conversion, defaulting, or copying is needed. + */ + if (cond & MaybeFalse) { + /* + * A type check is needed. + */ + ++cur_symtab[indx].n_refs; /* non-modifying reference to source. */ + if (cdp != NULL) { + switch (typcd) { + case TypECInt: + *cdp = typ_chk(src, TypCInt); + break; + case TypEInt: + *cdp = typ_chk(src, int_typ); + break; + case TypTStr: + *cdp = typ_chk(src, str_typ); + break; + case TypTCset: + *cdp = typ_chk(src, cset_typ); + break; + default: + *cdp = typ_chk(src, typcd); + } + } + } + + if (cdp != NULL) { + /* + * Conversion from an integer to a C_integer can be done without + * any executable code; this is not considered a real conversion. + * It is accomplished by changing the symbol table so only the + * dword of the descriptor is accessed. + */ + switch (typcd) { + case TypCInt: + case TypECInt: + cur_symtab[indx].loc = loc_cpy(cur_symtab[indx].loc, M_CInt); + break; + } + } + } + else if (dest != NULL && cnv_flags == MayKeep && cond == MaybeTrue) { + /* + * There is an explicit destination, but no conversion, defaulting, + * or type checking is needed. Just copy the value to the + * destination. + */ + ++cur_symtab[indx].n_refs; /* non-modifying reference to source */ + if (cdp != NULL) { + src_loc = cur_symtab[indx].loc; + switch (typcd) { + case TypCInt: + case TypECInt: + /* + * The value is in the dword of the descriptor. + */ + src_loc = loc_cpy(src_loc, M_CInt); + break; + } + *cdp = il_copy(dest, src_loc); + } + } + else if (cnv_flags == MayDefault) { + /* + * The default value is used. + */ + if (dest == NULL) + ++cur_symtab[indx].n_mods; /* modifying reference */ + if (cdp != NULL) + *cdp = il_dflt(typcd, src, dflt, dest); + } + else { + /* + * Produce code to do the actual conversion. + * Determine whether the source location is being modified + * or just referenced. + */ + if (dest == NULL) { + /* + * "In place" conversion. + */ + switch (typcd) { + case TypCDbl: + case TypCInt: + case TypECInt: + /* + * not really converted in-place. + */ + ++cur_symtab[indx].n_refs; /* non-modifying reference */ + break; + default: + ++cur_symtab[indx].n_mods; /* modifying reference */ + } + } + else + ++cur_symtab[indx].n_refs; /* non-modifying reference */ + + if (cdp != NULL) + *cdp = il_cnv(typcd, src, dflt, dest); + } + } + return cond; + } + +/* + * ilc_anlz - gather information about in-line C code. + */ +static void ilc_anlz(ilc) +struct il_c *ilc; + { + while (ilc != NULL) { + switch(ilc->il_c_type) { + case ILC_Ref: + /* + * Non-modifying reference to variable + */ + if (ilc->n != RsltIndx) { + ++cur_symtab[ilc->n].n_refs; + } + break; + + case ILC_Mod: + /* + * Modifying reference to variable + */ + if (ilc->n != RsltIndx) { + ++cur_symtab[ilc->n].n_mods; + } + break; + + case ILC_Ret: + /* + * Return statement. + */ + ++n_ret; + ret_anlz(ilc); + break; + + case ILC_Susp: + /* + * Suspend statement. + */ + ++n_susp; + ret_anlz(ilc); + break; + + case ILC_CGto: + /* + * Conditional goto. + */ + ilc_anlz(ilc->code[0]); + break; + } + ilc = ilc->next; + } + } + +/* + * ret_anlz - gather information about the in-line C code associated + * with a return or suspend. + */ +static void ret_anlz(ilc) +struct il_c *ilc; + { + int i; + int j; + + /* + * See if the code is simply returning a parameter. + */ + if (ilc->n == RetDesc && ilc->code[0]->il_c_type == ILC_Ref && + ilc->code[0]->next == NULL) { + j = ilc->code[0]->n; + ++cur_symtab[j].n_refs; + ++cur_symtab[j].n_rets; + } + else { + for (i = 0; i < 3 && ilc->code[i] != NULL; ++i) + ilc_anlz(ilc->code[i]); + } + } + +/* + * deref_il - dummy routine to pass to a code walk. + */ +/*ARGSUSED*/ +static int defer_il(il) +struct il_code *il; + { + /* + * Called for each case in a type_case statement that might be selected. + * However, the actual analysis of the case, if it is needed, + * is done elsewhere, so just return. + */ + return 0; + } + +/* + * findcases - determine how many cases of an type_case statement may + * be true. If there are two or less, determine the "if" statement + * that can be used (if there are more than two, the code is not + * in-lined). + */ +void findcases(il, has_dflt, case_anlz) +struct il_code *il; +int has_dflt; +struct case_anlz *case_anlz; + { + int i; + + case_anlz->n_cases = 0; + case_anlz->typcd = -1; + case_anlz->il_then = NULL; + case_anlz->il_else = NULL; + i = type_case(il, defer_il, case_anlz); + /* + * See if the explicit cases have accounted for all possible + * types that might be present. + */ + if (i == -1) { /* all types accounted for */ + if (case_anlz->il_else == NULL && case_anlz->il_then != NULL) { + /* + * We don't need to actually check the type. + */ + case_anlz->il_else = case_anlz->il_then; + case_anlz->il_then = NULL; + case_anlz->typcd = -1; + } + } + else { /* not all types accounted for */ + if (case_anlz->il_else != NULL) + case_anlz->n_cases = 3; /* force no inlining */ + else if (has_dflt) + case_anlz->il_else = il->u[i].fld; /* default */ + } + + if (case_anlz->n_cases > 2) + n_branches = 2; /* no in-lining */ + else if (case_anlz->il_then != NULL) + ++n_branches; + } + + +/* + * tc_anlz - analyze a type_case statement. It is only of interest for + * in-lining if it can be reduced to an "if" statement or an + * unconditional statement. + */ +static int tc_anlz(il, has_dflt) +struct il_code *il; +int has_dflt; + { + struct case_anlz case_anlz; + int fall_thru; + int indx; + + findcases(il, has_dflt, &case_anlz); + + if (case_anlz.il_else == NULL) + fall_thru = 1; /* either no code at all or condition with no "else" */ + else + fall_thru = 0; /* either unconditional or if-then-else: check code */ + + if (case_anlz.il_then != NULL) { + fall_thru |= il_anlz(case_anlz.il_then); + indx = il->u[0].fld->u[0].n; /* symbol table index of variable */ + if (indx < cur_symtyps->nsyms) + ++cur_symtab[indx].n_refs; + } + if (case_anlz.il_else != NULL) + fall_thru |= il_anlz(case_anlz.il_else); + return fall_thru; + } + +/* + * arth_anlz - analyze the type checking of an arith_case statement. + */ +void arth_anlz(var1, var2, maybe_int, maybe_dbl, chk1, conv1p, chk2, conv2p) +struct il_code *var1; +struct il_code *var2; +int *maybe_int; +int *maybe_dbl; +int *chk1; +struct code **conv1p; +int *chk2; +struct code **conv2p; + { + int cond; + int cnv_typ; + + + /* + * First do an analysis to find out which cases are needed. This is + * more accurate than analysing the conversions separately, but does + * not get all the information we need. + */ + eval_arith(var1->u[0].n, var2->u[0].n, maybe_int, maybe_dbl); + + if (*maybe_int & (largeints | *maybe_dbl)) { + /* + * Too much type checking; don't bother with these cases. Force no + * in-lining. + */ + n_branches += 2; + } + else { + if (*maybe_int) + cnv_typ = TypCInt; + else + cnv_typ = TypCDbl; + + /* + * See exactly what kinds of conversions/type checks are needed and, + * if requested, generate code for them. + */ + *chk1 = 0; + *chk2 = 0; + + cond = cnv_anlz(cnv_typ, var1, NULL, NULL, conv1p); + if (cond & MaybeFalse) { + ++n_branches; /* run-time decision */ + *chk1 = 1; + if (var1->u[0].n < cur_symtyps->nsyms) + ++cur_symtab[var1->u[0].n].n_refs; /* used in runerr2() */ + } + cond = cnv_anlz(cnv_typ, var2, NULL, NULL, conv2p); + if (cond & MaybeFalse) { + ++n_branches; /* run-time decision */ + *chk2 = 1; + if (var2->u[0].n < cur_symtyps->nsyms) + ++cur_symtab[var2->u[0].n].n_refs; /* used in runerr2() */ + } + } + } diff --git a/src/iconc/inline.c b/src/iconc/inline.c new file mode 100644 index 0000000..234229c --- /dev/null +++ b/src/iconc/inline.c @@ -0,0 +1,2007 @@ +/* + * inline.c - routines to put run-time routines in-line. + */ +#include "../h/gsupport.h" +#include "ctrans.h" +#include "ccode.h" +#include "csym.h" +#include "ctree.h" +#include "cproto.h" +#include "cglobals.h" + +/* + * Prototypes for static functions. + */ +static void arth_arg ( struct il_code *var, + struct val_loc *v_orig, int chk, + struct code *cnv); +static int body_fnc (struct il_code *il); +static void chkforblk (void); +static void cnv_dest (int loc, int is_cstr, + struct il_code *src, int sym_indx, + struct il_c *dest, struct code *cd, int i); +static void dwrd_asgn (struct val_loc *vloc, char *typ); +static struct il_c *line_ilc (struct il_c *ilc); +static int gen_if (struct code *cond_cd, + struct il_code *il_then, + struct il_code *il_else, + struct val_loc **locs); +static int gen_il (struct il_code *il); +static void gen_ilc (struct il_c *il); +static void gen_ilret (struct il_c *ilc); +static int gen_tcase (struct il_code *il, int has_dflt); +static void il_var (struct il_code *il, struct code *cd, + int indx); +static void mrg_locs (struct val_loc **locs); +static struct code *oper_lbl (char *s); +static void part_asgn (struct val_loc *vloc, char *asgn, + struct il_c *value); +static void rstr_locs (struct val_loc **locs); +static struct val_loc **sav_locs (void); +static void sub_ilc (struct il_c *ilc, struct code *cd, int indx); + +/* + * There are many parameters that are shared by multiple routines. There + * are copied into statics. + */ +static struct val_loc *rslt; /* result location */ +static struct code **scont_strt; /* label following operation code */ +static struct code **scont_fail; /* resumption label for in-line suspend */ +static struct c_fnc *cont; /* success continuation */ +static struct implement *impl; /* data base entry for operation */ +static int nsyms; /* number symbols in operation symbol table */ +static int n_vararg; /* size of variable part of arg list */ +static nodeptr intrnl_lftm; /* lifetime of internal variables */ +static struct val_loc **tended; /* array of tended locals */ + +/* + * gen_inlin - generate in-line code for an operation. + */ +void gen_inlin(il, r, strt, fail, c, ip, ns, st, n, dcl_var, n_va) +struct il_code *il; +struct val_loc *r; +struct code **strt; +struct code **fail; +struct c_fnc *c; +struct implement *ip; +int ns; +struct op_symentry *st; +nodeptr n; +int dcl_var; +int n_va; + { + struct code *cd; + struct val_loc *tnd; + int i; + + /* + * Copy arguments in to globals. + */ + rslt = r; + scont_strt = strt; + scont_fail = fail; + cont = c; + impl = ip; + nsyms = ns; + cur_symtab = st; + intrnl_lftm = n->intrnl_lftm; + cur_symtyps = n->symtyps; + n_vararg = n_va; + + /* + * Generate code to initialize local tended descriptors and determine + * how to access the descriptors. + */ + for (i = 0; i < impl->ntnds; ++i) { + if (cur_symtab[dcl_var].n_refs + cur_symtab[dcl_var].n_mods > 0) { + tnd = chk_alc(NULL, n->intrnl_lftm); + switch (impl->tnds[i].var_type) { + case TndDesc: + cur_symtab[dcl_var].loc = tnd; + break; + case TndStr: + cd = alc_ary(2); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = tnd; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = emptystr;"; + cd_add(cd); + cur_symtab[dcl_var].loc = loc_cpy(tnd, M_CharPtr); + break; + case TndBlk: + cd = alc_ary(2); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = tnd; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = nullptr;"; + cd_add(cd); + cur_symtab[dcl_var].loc = loc_cpy(tnd, M_BlkPtr); + cur_symtab[dcl_var].loc->blk_name = impl->tnds[i].blk_name; + break; + } + if (impl->tnds[i].init != NULL) { + cd = alc_ary(4); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = cur_symtab[dcl_var].loc; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = "; + sub_ilc(impl->tnds[i].init, cd, 2); + cd->ElemTyp(3) = A_Str; + cd->Str(3) = ";"; + cd_add(cd); + } + } + ++dcl_var; + } + + /* + * If there are local non-tended variables, generate code for the + * declarations, placing everything in braces. + */ + if (impl->nvars > 0) { + cd = NewCode(0); + cd->cd_id = C_LBrack; /* { */ + cd_add(cd); + for (i = 0; i < impl->nvars; ++i) { + if (cur_symtab[dcl_var].n_refs + cur_symtab[dcl_var].n_mods > 0) { + gen_ilc(impl->vars[i].dcl); + cur_symtab[dcl_var].loc = cvar_loc(impl->vars[i].name); + } + ++dcl_var; + } + } + + gen_il(il); /* generate executable code */ + + if (impl->nvars > 0) { + cd = NewCode(0); + cd->cd_id = C_RBrack; /* } */ + cd_add(cd); + } + } + +/* + * gen_il - generate code from a sub-tree of in-line code from the data + * base. Determine if execution can continue past this code. + * + */ +static int gen_il(il) +struct il_code *il; + { + struct code *cd; + struct code *cd1; + struct il_code *il_cond; + struct il_code *il_then; + struct il_code *il_else; + struct il_code *il_t; + struct val_loc **locs; + struct val_loc **locs1; + struct val_loc *tnd; + int fall_thru; + int cond; + int ncases; + int indx; + int ntended; + int i; + + if (il == NULL) + return 1; + + switch (il->il_type) { + case IL_Const: /* should have been replaced by literal node */ + return 1; + + case IL_If1: + case IL_If2: + /* + * if-then or if-then-else statement. + */ + il_then = il->u[1].fld; + if (il->il_type == IL_If2) + il_else = il->u[2].fld; + else + il_else = NULL; + il_cond = il->u[0].fld; + if (il->u[0].fld->il_type == IL_Bang) { + il_cond = il_cond->u[0].fld; + il_t = il_then; + il_then = il_else; + il_else = il_t; + } + locs = sav_locs(); + cond = cond_anlz(il_cond, &cd1); + if (cond == (MaybeTrue | MaybeFalse)) + fall_thru = gen_if(cd1, il_then, il_else, locs); + else { + if (cd1 != NULL) { + cd_add(cd1); /* condition contains needed conversions */ + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = ";"; + cd_add(cd); + } + if (cond == MaybeTrue) + fall_thru = gen_il(il_then); + else if (cond == MaybeFalse) { + locs1 = sav_locs(); + rstr_locs(locs); + locs = locs1; + fall_thru = gen_il(il_else); + } + mrg_locs(locs); + } + return fall_thru; + + case IL_Tcase1: + /* + * type_case statement with no default clause. + */ + return gen_tcase(il, 0); + + case IL_Tcase2: + /* + * type_case statement with a default clause. + */ + return gen_tcase(il, 1); + + case IL_Lcase: + /* + * len_case statement. Determine which case matches the number + * of arguments. + */ + ncases = il->u[0].n; + indx = 1; + for (i = 0; i < ncases; ++i) { + if (il->u[indx++].n == n_vararg) /* selection number */ + return gen_il(il->u[indx].fld); /* action */ + ++indx; + } + return gen_il(il->u[indx].fld); /* default */ + + case IL_Acase: { + /* + * arith_case statement. + */ + struct il_code *var1; + struct il_code *var2; + struct val_loc *v_orig1; + struct val_loc *v_orig2; + struct code *cnv1; + struct code *cnv2; + int maybe_int; + int maybe_dbl; + int chk1; + int chk2; + + var1 = il->u[0].fld; + var2 = il->u[1].fld; + v_orig1 = cur_symtab[var1->u[0].n].loc; /* remember for error msgs */ + v_orig2 = cur_symtab[var2->u[0].n].loc; /* remember for error msgs */ + arth_anlz(var1, var2, &maybe_int, &maybe_dbl, &chk1, &cnv1, + &chk2, &cnv2); + + /* + * This statement is in-lined if there is only C integer + * arithmetic, only C double arithmetic, or only a run-time + * error. + */ + arth_arg(var1, v_orig1, chk1, cnv1); + arth_arg(var2, v_orig2, chk2, cnv2); + if (maybe_int) + return gen_il(il->u[2].fld); /* C_integer action */ + else if (maybe_dbl) + return gen_il(il->u[4].fld); /* C_double action */ + else + return 0; + } + + case IL_Err1: + /* + * runerr() with no offending value. + */ + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "err_msg("; + cd->ElemTyp(1) = A_Intgr; + cd->Intgr(1) = il->u[0].n; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ", NULL);"; + cd_add(cd); + if (err_conv) + cd_add(sig_cd(on_failure, cur_fnc)); + for (i = 0; i < nsyms; ++i) + cur_symtab[i].loc = NULL; + return 0; + + case IL_Err2: + /* + * runerr() with an offending value. Note the reference to + * the offending value descriptor. + */ + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "err_msg("; + cd->ElemTyp(1) = A_Intgr; + cd->Intgr(1) = il->u[0].n; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ", &("; + il_var(il->u[1].fld, cd, 3); + cd->ElemTyp(4) = A_Str; + cd->Str(4) = "));"; + cd_add(cd); + if (err_conv) + cd_add(sig_cd(on_failure, cur_fnc)); + for (i = 0; i < nsyms; ++i) + cur_symtab[i].loc = NULL; + return 0; + + case IL_Lst: + /* + * Two consecutive pieces of RTL code. + */ + fall_thru = gen_il(il->u[0].fld); + if (fall_thru) + fall_thru = gen_il(il->u[1].fld); + return fall_thru; + + case IL_Block: + /* + * inline {...} statement. + * + * Allocate and initialize any tended locals. + */ + ntended = il->u[1].n; + if (ntended > 0) + tended = (struct val_loc **)alloc((unsigned int) + sizeof(struct val_loc *) * ntended); + for (i = 2; i - 2 < ntended; ++i) { + tnd = chk_alc(NULL, intrnl_lftm); + tended[i - 2] = tnd; + switch (il->u[i].n) { + case TndDesc: + break; + case TndStr: + cd = alc_ary(2); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = tnd; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = emptystr;"; + cd_add(cd); + break; + case TndBlk: + cd = alc_ary(2); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = tnd; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = " = nullptr;"; + cd_add(cd); + break; + } + } + gen_ilc(il->u[i].c_cd); /* body of block */ + /* + * See if execution can fall through this code. + */ + if (il->u[0].n) + return 1; + else { + for (i = 0; i < nsyms; ++i) + cur_symtab[i].loc = NULL; + return 0; + } + + case IL_Call: + /* + * call to body function. + */ + return body_fnc(il); + + case IL_Abstr: + /* + * abstract type computation. Only used by type inference. + */ + return 1; + + default: + fprintf(stderr, "compiler error: unknown info in data base\n"); + exit(1); + /* NOTREACHED */ + } + } + +/* + * arth_arg - in-line code to check a conversion for an arith_case statement. + */ +static void arth_arg(var, v_orig, chk, cnv) +struct il_code *var; +struct val_loc *v_orig; +int chk; +struct code *cnv; + { + struct code *lbl; + struct code *cd; + + if (chk) { + /* + * Must check the conversion. + */ + lbl = oper_lbl("converted"); + cd_add(lbl); + cur_fnc->cursor = lbl->prev; /* code goes before label */ + if (cnv != NULL) { + cd = NewCode(2); + cd->cd_id = C_If; + cd->Cond = cnv; + cd->ThenStmt = mk_goto(lbl); + cd_add(cd); + } + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "err_msg(102, &("; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = v_orig; /* var location before conversion */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = "));"; + cd_add(cd); + if (err_conv) + cd_add(sig_cd(on_failure, cur_fnc)); + cur_fnc->cursor = lbl; + } + else if (cnv != NULL) { + cd_add(cnv); /* conversion cannot fail */ + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = ";"; + cd_add(cd); + } + } + +/* + * body_fnc - generate code to call a body function. + */ +static int body_fnc(il) +struct il_code *il; + { + struct code *arg_lst; + struct code *cd; + struct c_fnc *cont1; + char *oper_nm; + int ret_val; + int ret_flag; + int need_rslt; + int num_sbuf; + int num_cbuf; + int expl_args; + int arglst_sz; /* size of arg list in number of code pieces */ + int il_indx; + int cd_indx; + int proto_prt; + int i; + + /* + * Determine if a function prototype has been printed yet for this + * body function. + */ + proto_prt = il->u[0].n; + il->u[0].n = 1; + + /* + * Construct the name of the body function. + */ + oper_nm = (char *)alloc((unsigned int)(strlen(impl->name) + 6)); + sprintf(oper_nm, "%c%c%c%c_%s", impl->oper_typ, impl->prefix[0], + impl->prefix[1], (char)il->u[1].n, impl->name); + + /* + * Extract from the call the flags and other information describing + * the function, then use this information to deduce the arguments + * needed by the function. + */ + ret_val = il->u[2].n; + ret_flag = il->u[3].n; + need_rslt = il->u[4].n; + num_sbuf = il->u[5].n; + num_cbuf = il->u[6].n; + expl_args = il->u[7].n; + + /* + * determine how large the argument list is. + */ + arglst_sz = 2 * expl_args - 1; + if (num_sbuf > 0) + arglst_sz += 3; + if (num_cbuf > 0) + arglst_sz += 2; + if (need_rslt) + arglst_sz += 3; + if (arglst_sz > 0) + arg_lst = alc_ary(arglst_sz); + else + arg_lst = alc_ary(0); + + if (!proto_prt) { + /* + * Determine whether the body function returns a C integer, double, + * no value, or a signal. + */ + switch (ret_val) { + case RetInt: + fprintf(inclfile, "C_integer %s (", oper_nm); + break; + case RetDbl: + fprintf(inclfile, "double %s (", oper_nm); + break; + case RetNoVal: + fprintf(inclfile, "void %s (", oper_nm); + break; + case RetSig: + fprintf(inclfile, "int %s (", oper_nm); + break; + } + } + + /* + * Produce prototype and code for the explicit arguments in the + * function call. Note that the call entry contains C code for both. + */ + il_indx = 8; + cd_indx = 0; + while (expl_args--) { + if (cd_indx > 0) { + /* + * Not first entry, precede by ','. + */ + arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ + arg_lst->Str(cd_indx) = ", "; + if (!proto_prt) + fprintf(inclfile, ", "); + ++cd_indx; + } + if (!proto_prt) + fprintf(inclfile, "%s", il->u[il_indx].c_cd->s); /* parameter dcl */ + ++il_indx; + sub_ilc(il->u[il_indx++].c_cd, arg_lst, cd_indx++); + } + + /* + * If string buffers are needed, allocate them and pass pointer to + * function. + */ + if (num_sbuf > 0) { + if (cd_indx > 0) { + /* + * Not first entry, precede by ','. + */ + arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ + arg_lst->Str(cd_indx) = ", "; + if (!proto_prt) + fprintf(inclfile, ", "); + ++cd_indx; + } + arg_lst->ElemTyp(cd_indx) = A_Str; + arg_lst->Str(cd_indx) = "(char (*)[MaxCvtLen])"; + ++cd_indx; + arg_lst->ElemTyp(cd_indx) = A_SBuf; + arg_lst->Intgr(cd_indx) = alc_sbufs(num_sbuf, intrnl_lftm); + if (!proto_prt) + fprintf(inclfile, "char (*r_sbuf)[MaxCvtLen]"); + ++cd_indx; + } + + /* + * If cset buffers are needed, allocate them and pass pointer to + * function. + */ + if (num_cbuf > 0) { + if (cd_indx > 0) { + /* + * Not first entry, precede by ','. + */ + arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ + arg_lst->Str(cd_indx) = ", "; + if (!proto_prt) + fprintf(inclfile, ", "); + ++cd_indx; + } + arg_lst->ElemTyp(cd_indx) = A_CBuf; + arg_lst->Intgr(cd_indx) = alc_cbufs(num_cbuf, intrnl_lftm); + if (!proto_prt) + fprintf(inclfile, "struct b_cset *r_cbuf"); + ++cd_indx; + } + + /* + * See if the function needs a pointer to the result location + * of the operation. + */ + if (need_rslt) { + if (cd_indx > 0) { + /* + * Not first entry, precede by ','. + */ + arg_lst->ElemTyp(cd_indx) = A_Str; /* , */ + arg_lst->Str(cd_indx) = ", "; + if (!proto_prt) + fprintf(inclfile, ", "); + ++cd_indx; + } + arg_lst->ElemTyp(cd_indx) = A_Str; /* location of result */ + arg_lst->Str(cd_indx) = "&"; + ++cd_indx; + arg_lst->ElemTyp(cd_indx) = A_ValLoc; + arg_lst->ValLoc(cd_indx) = rslt; + if (!proto_prt) + fprintf(inclfile, "dptr rslt"); + ++cd_indx; + } + + if (!proto_prt) { + /* + * The last possible argument is the success continuation. + * If there are no arguments, indicate this in the prototype. + */ + if (ret_flag & DoesSusp) { + if (cd_indx > 0) + fprintf(inclfile, ", "); + fprintf(inclfile, "continuation succ_cont"); + } + else if (cd_indx == 0) + fprintf(inclfile, "void"); + fprintf(inclfile, ");\n"); + } + + /* + * Does this call need the success continuation for the operation. + */ + if (ret_flag & DoesSusp) + cont1 = cont; + else + cont1 = NULL; + + switch (ret_val) { + case RetInt: + /* + * The body function returns a C integer. + */ + cd = alc_ary(6); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = rslt; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = ".vword.integr = "; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = oper_nm; + cd->ElemTyp(3) = A_Str; + cd->Str(3) = "("; + cd->ElemTyp(4) = A_Ary; + cd->Array(4) = arg_lst; + cd->ElemTyp(5) = A_Str; + cd->Str(5) = ");"; + cd_add(cd); + dwrd_asgn(rslt, "Integer"); + cd_add(mk_goto(*scont_strt)); + break; + case RetDbl: + /* + * The body function returns a C double. + */ + cd = alc_ary(6); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = rslt; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = ".vword.bptr = (union block *)alcreal("; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = oper_nm; + cd->ElemTyp(3) = A_Str; + cd->Str(3) = "("; + cd->ElemTyp(4) = A_Ary; + cd->Array(4) = arg_lst; + cd->ElemTyp(5) = A_Str; + cd->Str(5) = "));"; + cd_add(cd); + dwrd_asgn(rslt, "Real"); + chkforblk(); /* make sure the block allocation succeeded */ + cd_add(mk_goto(*scont_strt)); + break; + case RetNoVal: + /* + * The body function does not directly return a value. + */ + cd = alc_ary(4); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = oper_nm; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = "("; + cd->ElemTyp(2) = A_Ary; + cd->Array(2) = arg_lst; + cd->ElemTyp(3) = A_Str; + cd->Str(3) = ");"; + cd_add(cd); + if (ret_flag & DoesFail | (err_conv && (ret_flag & DoesEFail))) + cd_add(sig_cd(on_failure, cur_fnc)); + else if (ret_flag & DoesRet) + cd_add(mk_goto(*scont_strt)); + break; + case RetSig: + /* + * The body function returns a signal. + */ + callo_add(oper_nm, ret_flag, cont1, 0, arg_lst, mk_goto(*scont_strt)); + break; + } + /* + * See if execution can fall through this call. + */ + if (ret_flag & DoesFThru) + return 1; + else { + for (i = 0; i < nsyms; ++i) + cur_symtab[i].loc = NULL; + return 0; + } + } + + +/* + * il_var - generate code for a possibly subscripted variable into + * an element of a code array. + */ +static void il_var(il, cd, indx) +struct il_code *il; +struct code *cd; +int indx; + { + struct code *cd1; + + if (il->il_type == IL_Subscr) { + /* + * Subscripted variable. + */ + cd1 = cd; + cd = alc_ary(4); + cd1->ElemTyp(indx) = A_Ary; + cd1->Array(indx) = cd; + indx = 0; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = "["; + cd->ElemTyp(2) = A_Intgr; + cd->Intgr(2) = il->u[1].n; + cd->ElemTyp(3) = A_Str; + cd->Str(3) = "]"; + } + + /* + * See if this is the result location of the operation or an ordinary + * variable. + */ + cd->ElemTyp(indx) = A_ValLoc; + if (il->u[0].n == RsltIndx) + cd->ValLoc(indx) = rslt; + else + cd->ValLoc(indx) = cur_symtab[il->u[0].n].loc; + } + +/* + * part_asgn - generate code for an assignment to (part of) a descriptor. + */ +static void part_asgn(vloc, asgn, value) +struct val_loc *vloc; +char *asgn; +struct il_c *value; + { + struct code *cd; + + cd = alc_ary(4); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = vloc; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = asgn; + sub_ilc(value, cd, 2); /* value */ + cd->ElemTyp(3) = A_Str; + cd->Str(3) = ";"; + cd_add(cd); + } + +/* + * dwrd_asgn - generate code to assign a type code to the dword of a descriptor. + */ +static void dwrd_asgn(vloc, typ) +struct val_loc *vloc; +char *typ; + { + struct code *cd; + + cd = alc_ary(4); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = vloc; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = ".dword = D_"; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = typ; + cd->ElemTyp(3) = A_Str; + cd->Str(3) = ";"; + cd_add(cd); + } + +/* + * sub_ilc - generate code from a sequence of C code and place it + * in a slot in a code array. + */ +static void sub_ilc(ilc, cd, indx) +struct il_c *ilc; +struct code *cd; +int indx; + { + struct il_c *ilc1; + struct code *cd1; + int n; + + /* + * Count the number of pieces of C code to process. + */ + n = 0; + for (ilc1 = ilc; ilc1 != NULL; ilc1 = ilc1->next) + ++n; + + /* + * If there is only one piece of code, place it directly in the + * slot of the array. Otherwise allocate a sub-array and place it + * in the slot. + */ + if (n > 1) { + cd1 = cd; + cd = alc_ary(n); + cd1->ElemTyp(indx) = A_Ary; + cd1->Array(indx) = cd; + indx = 0; + } + + while (ilc != NULL) { + switch (ilc->il_c_type) { + case ILC_Ref: + case ILC_Mod: + /* + * Reference to variable in symbol table. + */ + cd->ElemTyp(indx) = A_ValLoc; + if (ilc->n == RsltIndx) + cd->ValLoc(indx) = rslt; + else { + if (ilc->s == NULL) + cd->ValLoc(indx) = cur_symtab[ilc->n].loc; + else { + /* + * Access the entire descriptor. + */ + cd->ValLoc(indx) = loc_cpy(cur_symtab[ilc->n].loc, M_None); + } + } + break; + + case ILC_Tend: + /* + * Reference to a tended variable. + */ + cd->ElemTyp(indx) = A_ValLoc; + cd->ValLoc(indx) = tended[ilc->n]; + break; + + case ILC_Str: + /* + * String representing C code. + */ + cd->ElemTyp(indx) = A_Str; + cd->Str(indx) = ilc->s; + break; + + case ILC_SBuf: + /* + * String buffer for a conversion. + */ + cd->ElemTyp(indx) = A_SBuf; + cd->Intgr(indx) = alc_sbufs(1, intrnl_lftm); + break; + + case ILC_CBuf: + /* + * Cset buffer for a conversion. + */ + cd->ElemTyp(indx) = A_CBuf; + cd->Intgr(indx) = alc_cbufs(1, intrnl_lftm); + break; + + + default: + fprintf(stderr, "compiler error: unknown info in data base\n"); + exit(1); + } + ilc = ilc->next; + ++indx; + } + + } + +/* + * gen_ilret - generate code to set the result value from a suspend or + * return. + */ +static void gen_ilret(ilc) +struct il_c *ilc; + { + struct il_c *ilc0; + struct code *cd; + char *cap_id; + int typcd; + + if (rslt == &ignore) + return; /* Don't bother computing the result; it's never used */ + + ilc0 = ilc->code[0]; + typcd = ilc->n; + + if (typcd < 0) { + /* + * RTL returns that do not look like function calls to standard Icon + * type name. + */ + switch (typcd) { + case TypCInt: + /* + * return/suspend C_integer ; + */ + part_asgn(rslt, ".vword.integr = ", ilc0); + dwrd_asgn(rslt, "Integer"); + break; + case TypCDbl: + /* + * return/suspend C_double ; + */ + cd = alc_ary(4); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = rslt; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = ".vword.bptr = (union block *)alcreal("; + sub_ilc(ilc0, cd, 2); /* value */ + cd->ElemTyp(3) = A_Str; + cd->Str(3) = ");"; + cd_add(cd); + dwrd_asgn(rslt, "Real"); + chkforblk(); /* make sure the block allocation succeeded */ + break; + case TypCStr: + /* + * return/suspend C_string ; + */ + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "AsgnCStr("; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = rslt; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ", "; + sub_ilc(ilc0, cd, 3); /* */ + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ");"; + cd_add(cd); + break; + case RetDesc: + /* + * return/suspend ; + */ + part_asgn(rslt, " = ", ilc0); + break; + case RetNVar: + /* + * return/suspend named_var(); + */ + part_asgn(rslt, ".vword.descptr = ", ilc0); + dwrd_asgn(rslt, "Var"); + break; + case RetSVar: + /* + * return/suspend struct_var(, ); + */ + part_asgn(rslt, ".vword.descptr = (dptr)", ilc->code[1]); + cd = alc_ary(6); + cd->ElemTyp(0) = A_ValLoc; + cd->ValLoc(0) = rslt; + cd->ElemTyp(1) = A_Str; + cd->Str(1) = ".dword = D_Var + ((word *)"; + sub_ilc(ilc0, cd, 2); /* value */ + cd->ElemTyp(3) = A_Str; + cd->Str(3) = " - (word *)"; + cd->ElemTyp(4) = A_ValLoc; + cd->ValLoc(4) = rslt; + cd->ElemTyp(5) = A_Str; + cd->Str(5) = ".vword.descptr);"; + cd_add(cd); + break; + case RetNone: + /* + * return/suspend result; + * + * Result already set, do nothing. + */ + break; + default: + fprintf(stderr, + "compiler error: unknown RLT return in data base\n"); + exit(1); + /* NOTREACHED */ + } + } + else { + /* + * RTL returns that look like function calls to standard Icon type + * names. + */ + cap_id = icontypes[typcd].cap_id; + switch (icontypes[typcd].rtl_ret) { + case TRetBlkP: + /* + * return/suspend (); + */ + part_asgn(rslt, ".vword.bptr = (union block *)", ilc0); + dwrd_asgn(rslt, cap_id); + break; + case TRetDescP: + /* + * return/suspend (); + */ + part_asgn(rslt, ".vword.descptr = (dptr)", ilc0); + dwrd_asgn(rslt, cap_id); + break; + case TRetCharP: + /* + * return/suspend (); + */ + part_asgn(rslt, ".vword.sptr = (char *)", ilc0); + dwrd_asgn(rslt, cap_id); + break; + case TRetCInt: + /* + * return/suspend (); + */ + part_asgn(rslt, ".vword.integr = (word)", ilc0); + dwrd_asgn(rslt, cap_id); + break; + case TRetSpcl: + /* + * RTL returns that look like function calls to standard type + * names but take more than one argument. + */ + if (typcd == str_typ) { + /* + * return/suspend string(, ); + */ + part_asgn(rslt, ".vword.sptr = ", ilc->code[1]); + part_asgn(rslt, ".dword = ", ilc0); + } + else if (typcd == stv_typ) { + /* + * return/suspend substr(, , ); + */ + cd = alc_ary(9); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "SubStr(&"; + cd->ElemTyp(1) = A_ValLoc; + cd->ValLoc(1) = rslt; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ", "; + sub_ilc(ilc0, cd, 3); + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ", "; + sub_ilc(ilc->code[2], cd, 5); + cd->ElemTyp(6) = A_Str; + cd->Str(6) = ", "; + sub_ilc(ilc->code[1], cd, 7); + cd->ElemTyp(8) = A_Str; + cd->Str(8) = ");"; + cd_add(cd); + chkforblk(); /* make sure the block allocation succeeded */ + } + else { + fprintf(stderr, + "compiler error: unknown RLT return in data base\n"); + exit(1); + /* NOTREACHED */ + } + break; + default: + fprintf(stderr, + "compiler error: unknown RLT return in data base\n"); + exit(1); + /* NOTREACHED */ + } + } + } + +/* + * chkforblk - generate code to make sure the allocation of a block + * for the result descriptor was successful. + */ +static void chkforblk() + { + struct code *cd; + struct code *cd1; + struct code *lbl; + + lbl = alc_lbl("got allocation", 0); + cd_add(lbl); + cur_fnc->cursor = lbl->prev; /* code goes before label */ + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(3); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "("; + cd1->ElemTyp(1) = A_ValLoc; + cd1->ValLoc(1) = rslt; + cd1->ElemTyp(2) = A_Str; + cd1->Str(2) = ").vword.bptr != NULL"; + cd->Cond = cd1; + cd->ThenStmt = mk_goto(lbl); + cd_add(cd); + cd = alc_ary(1); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "err_msg(307, NULL);"; + cd_add(cd); + if (err_conv) + cd_add(sig_cd(on_failure, cur_fnc)); + cur_fnc->cursor = lbl; + } + +/* + * gen_ilc - generate code for an sequence of in-line C code. + */ +static void gen_ilc(ilc) +struct il_c *ilc; + { + struct il_c *ilc1; + struct code *cd; + struct code *cd1; + struct code *lbl1; + struct code *fail_sav; + struct code **lbls; + int max_lbl; + int i; + + /* + * Determine how many labels there are in the code and allocate an + * array to map from label numbers to labels in the code. + */ + max_lbl = -1; + for (ilc1 = ilc; ilc1 != NULL; ilc1 = ilc1->next) { + switch(ilc1->il_c_type) { + case ILC_CGto: + case ILC_Goto: + case ILC_Lbl: + if (ilc1->n > max_lbl) + max_lbl = ilc1->n; + } + } + ++max_lbl; /* adjust for 0 indexing */ + if (max_lbl > 0) { + lbls = (struct code **)alloc((unsigned int) sizeof(struct code *) * + max_lbl); + for (i = 0; i < max_lbl; ++i) + lbls[i] = NULL; + } + + while (ilc != NULL) { + switch(ilc->il_c_type) { + case ILC_Ref: + case ILC_Mod: + case ILC_Tend: + case ILC_SBuf: + case ILC_CBuf: + case ILC_Str: + /* + * The beginning of a sequence of code fragments that can be + * place on one line. + */ + ilc = line_ilc(ilc); + break; + + case ILC_Fail: + /* + * fail - perform failure action. + */ + cd_add(sig_cd(on_failure, cur_fnc)); + break; + + case ILC_EFail: + /* + * errorfail - same as fail if error conversion is supported. + */ + if (err_conv) + cd_add(sig_cd(on_failure, cur_fnc)); + break; + + case ILC_Ret: + /* + * return - set result location and jump out of operation. + */ + gen_ilret(ilc); + cd_add(mk_goto(*scont_strt)); + break; + + case ILC_Susp: + /* + * suspend - set result location. If there is a success + * continuation, call it. Otherwise the "continuation" + * will be generated in-line, so set up a resumption label. + */ + gen_ilret(ilc); + if (cont == NULL) + *scont_strt = cur_fnc->cursor; + lbl1 = oper_lbl("end suspend"); + cd_add(lbl1); + if (cont == NULL) + *scont_fail = lbl1; + else { + cur_fnc->cursor = lbl1->prev; + fail_sav = on_failure; + on_failure = lbl1; + callc_add(cont); + on_failure = fail_sav; + cur_fnc->cursor = lbl1; + } + break; + + case ILC_LBrc: + /* + * non-deletable '{' + */ + cd = NewCode(0); + cd->cd_id = C_LBrack; + cd_add(cd); + break; + + case ILC_RBrc: + /* + * non-deletable '}' + */ + cd = NewCode(0); + cd->cd_id = C_RBrack; + cd_add(cd); + break; + + case ILC_CGto: + /* + * Conditional goto. + */ + i = ilc->n; + if (lbls[i] == NULL) + lbls[i] = oper_lbl("within"); + cd = NewCode(2); + cd->cd_id = C_If; + cd1 = alc_ary(1); + sub_ilc(ilc->code[0], cd1, 0); + cd->Cond = cd1; + cd->ThenStmt = mk_goto(lbls[i]); + cd_add(cd); + break; + + case ILC_Goto: + /* + * Goto. + */ + i = ilc->n; + if (lbls[i] == NULL) + lbls[i] = oper_lbl("within"); + cd_add(mk_goto(lbls[i])); + break; + + case ILC_Lbl: + /* + * Label. + */ + i = ilc->n; + if (lbls[i] == NULL) + lbls[i] = oper_lbl("within"); + cd_add(lbls[i]); + break; + + default: + fprintf(stderr, "compiler error: unknown info in data base\n"); + exit(1); + } + ilc = ilc->next; + } + + if (max_lbl > 0) + free((char *)lbls); + } + +/* + * line_ilc - gather a line of in-line code. + */ +static struct il_c *line_ilc(ilc) +struct il_c *ilc; + { + struct il_c *ilc1; + struct il_c *last; + struct code *cd; + int n; + int i; + + /* + * Count the number of pieces in the line. Determine the last + * piece in the sequence; this is returned to the caller. + */ + n = 0; + ilc1 = ilc; + while (ilc1 != NULL) { + switch(ilc1->il_c_type) { + case ILC_Ref: + case ILC_Mod: + case ILC_Tend: + case ILC_SBuf: + case ILC_CBuf: + case ILC_Str: + ++n; + last = ilc1; + ilc1 = ilc1->next; + break; + default: + ilc1 = NULL; + } + } + + /* + * Construct the line. + */ + cd = alc_ary(n); + for (i = 0; i < n; ++i) { + switch(ilc->il_c_type) { + case ILC_Ref: + case ILC_Mod: + /* + * Reference to variable in symbol table. + */ + cd->ElemTyp(i) = A_ValLoc; + if (ilc->n == RsltIndx) + cd->ValLoc(i) = rslt; + else + cd->ValLoc(i) = cur_symtab[ilc->n].loc; + break; + + case ILC_Tend: + /* + * Reference to a tended variable. + */ + cd->ElemTyp(i) = A_ValLoc; + cd->ValLoc(i) = tended[ilc->n]; + break; + + case ILC_SBuf: + /* + * String buffer for a conversion. + */ + cd->ElemTyp(i) = A_SBuf; + cd->Intgr(i) = alc_sbufs(1, intrnl_lftm); + break; + + case ILC_CBuf: + /* + * Cset buffer for a conversion. + */ + cd->ElemTyp(i) = A_CBuf; + cd->Intgr(i) = alc_cbufs(1, intrnl_lftm); + break; + + case ILC_Str: + /* + * String representing C code. + */ + cd->ElemTyp(i) = A_Str; + cd->Str(i) = ilc->s; + break; + + default: + ilc = NULL; + } + ilc = ilc->next; + } + + cd_add(cd); + return last; + } + +/* + * generate code to perform simple type checking. + */ +struct code *typ_chk(var, typcd) +struct il_code *var; +int typcd; + { + struct code *cd; + + if (typcd == int_typ && largeints) { + /* + * Handle large integer support specially. + */ + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "(("; + il_var(var, cd, 1); /* value */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ").dword == D_Integer || ("; + il_var(var, cd, 3); /* value */ + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ").dword == D_Lrgint)"; + return cd; + } + else if (typcd < 0) { + /* + * Not a standard Icon type name. + */ + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + switch (typcd) { + case TypVar: + cd->Str(0) = "((("; + il_var(var, cd, 1); /* value */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ").dword & D_Var) == D_Var)"; + break; + case TypCInt: + cd->Str(0) = "(("; + il_var(var, cd, 1); /* value */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ").dword == D_Integer)"; + break; + } + } + else if (typcd == str_typ) { + cd = alc_ary(3); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "(!(("; + il_var(var, cd, 1); /* value */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ").dword & F_Nqual))"; + } + else { + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "(("; + il_var(var, cd, 1); /* value */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ").dword == D_"; + cd->ElemTyp(3) = A_Str; + cd->Str(3) = icontypes[typcd].cap_id; /* type name */ + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ")"; + } + + return cd; + } + +/* + * oper_lbl - generate a label with an associated comment that includes + * the operation name. + */ +static struct code *oper_lbl(s) +char *s; + { + char *sbuf; + + sbuf = (char *)alloc((unsigned int)(strlen(s) + strlen(impl->name) + 3)); + sprintf(sbuf, "%s: %s", s, impl->name); + return alc_lbl(sbuf, 0); + } + +/* + * sav_locs - save the current interpretation of symbols that may + * be affected by conversions. + */ +static struct val_loc **sav_locs() + { + struct val_loc **locs; + int i; + + if (nsyms == 0) + return NULL; + + locs = (struct val_loc **)alloc((unsigned int)(nsyms * + sizeof(struct val_loc *))); + for (i = 0; i < nsyms; ++i) + locs[i] = cur_symtab[i].loc; + return locs; + } + +/* + * rstr_locs - restore the interpretation of symbols that may + * have been affected by conversions. + */ +static void rstr_locs(locs) +struct val_loc **locs; + { + int i; + + for (i = 0; i < nsyms; ++i) + cur_symtab[i].loc = locs[i]; + free((char *)locs); + } + +/* + * mrg_locs - merge the interpretations of symbols along two execution + * paths. Any ambiguity is caught by rtt, so differences only occur + * if one path involves program termination so that the symbols + * no longer have an interpretation along that path. + */ +static void mrg_locs(locs) +struct val_loc **locs; + { + int i; + + for (i = 0; i < nsyms; ++i) + if (cur_symtab[i].loc == NULL) + cur_symtab[i].loc = locs[i]; + free((char *)locs); + } + +/* + * il_cnv - generate code for an in-line conversion. + */ +struct code *il_cnv(typcd, src, dflt, dest) +int typcd; +struct il_code *src; +struct il_c *dflt; +struct il_c *dest; + { + struct code *cd; + struct code *cd1; + int dflt_to_ptr; + int loc; + int is_cstr; + int sym_indx; + int n; + int i; + + sym_indx = src->u[0].n; + + /* + * Determine whether the address must be taken of a default value and + * whether the interpretation of the symbol in an in-place conversion + * changes. + */ + dflt_to_ptr = 0; + loc = PrmTend; + is_cstr = 0; + switch (typcd) { + case TypCInt: + case TypECInt: + loc = PrmInt; + break; + case TypCDbl: + loc = PrmDbl; + break; + case TypCStr: + is_cstr = 1; + break; + case TypEInt: + break; + case TypTStr: + case TypTCset: + dflt_to_ptr = 1; + break; + default: + /* + * Cset, real, integer, or string + */ + if (typcd == cset_typ || typcd == str_typ) + dflt_to_ptr = 1; + break; + } + + if (typcd == TypCDbl && !(eval_is(real_typ, sym_indx) & MaybeFalse)) { + /* + * Conversion from Icon real to C double. Just copy the C value + * from the block. + */ + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "(GetReal(&("; + il_var(src, cd, 1); + cd->ElemTyp(2) = A_Str; + cd->Str(2) = "), "; + cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, 3); + cd->ElemTyp(4) = A_Str; + cd->Str(4) = "), 1)"; + } + else if (typcd == TypCDbl && !largeints && + !(eval_is(int_typ, sym_indx) & MaybeFalse)) { + /* + * Conversion from Icon integer (not large integer) to C double. + * Do as a C conversion by an assigment. + */ + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "("; + cd->ElemTyp(2) = A_Str; + cd->Str(2) = " = IntVal( "; + cd->ElemTyp(4) = A_Str; + cd->Str(4) = "), 1)"; + /* + * Note that cnv_dest() must be called after the source is output + * in case it changes the location of the parameter. + */ + il_var(src, cd, 3); + cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, 1); + } + else { + /* + * Compute the number of code fragments required to construct the + * call to the conversion routine. + */ + n = 7; + if (dflt != NULL) + n += 2; + + cd = alc_ary(n); + + /* + * The names of simple conversions are distinguished from defaulting + * conversions by a prefix of "cnv_" or "def_". + */ + cd->ElemTyp(0) = A_Str; + if (dflt == NULL) + cd->Str(0) = "cnv_"; + else + cd->Str(0) = "def_"; + + /* + * Determine the name of the conversion routine. + */ + cd->ElemTyp(1) = A_Str; /* may be overridden */ + switch (typcd) { + case TypCInt: + cd->Str(1) = "c_int(&("; + break; + case TypCDbl: + cd->Str(1) = "c_dbl(&("; + break; + case TypCStr: + cd->Str(1) = "c_str(&("; + break; + case TypEInt: + cd->Str(1) = "eint(&("; + break; + case TypECInt: + cd->Str(1) = "ec_int(&("; + break; + case TypTStr: + /* + * Allocate a string buffer. + */ + cd1 = alc_ary(3); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "tstr("; + cd1->ElemTyp(1) = A_SBuf; + cd1->Intgr(1) = alc_sbufs(1, intrnl_lftm); + cd1->ElemTyp(2) = A_Str; + cd1->Str(2) = ", (&"; + cd->ElemTyp(1) = A_Ary; + cd->Array(1) = cd1; + break; + case TypTCset: + /* + * Allocate a cset buffer. + */ + cd1 = alc_ary(3); + cd1->ElemTyp(0) = A_Str; + cd1->Str(0) = "tcset("; + cd1->ElemTyp(1) = A_CBuf; + cd1->Intgr(1) = alc_cbufs(1, intrnl_lftm); + cd1->ElemTyp(2) = A_Str; + cd1->Str(2) = ", &("; + cd->ElemTyp(1) = A_Ary; + cd->Array(1) = cd1; + break; + default: + /* + * Cset, real, integer, or string + */ + if (typcd == cset_typ) + cd->Str(1) = "cset(&("; + else if (typcd == real_typ) + cd->Str(1) = "real(&("; + else if (typcd == int_typ) + cd->Str(1) = "int(&("; + else if (typcd == str_typ) + cd->Str(1) = "str(&("; + break; + } + + il_var(src, cd, 2); + + cd->ElemTyp(3) = A_Str; + if (dflt != NULL && dflt_to_ptr) + cd->Str(3) = "), &("; + else + cd->Str(3) = "), "; + + + /* + * Determine if this conversion has a default value. + */ + i = 4; + if (dflt != NULL) { + sub_ilc(dflt, cd, i); + ++i; + cd->ElemTyp(i) = A_Str; + if (dflt_to_ptr) + cd->Str(i) = "), "; + else + cd->Str(i) = ", "; + ++i; + } + + cd->ElemTyp(i) = A_Str; + cd->Str(i) = "&("; + ++i; + cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, i); + ++i; + cd->ElemTyp(i) = A_Str; + cd->Str(i) = "))"; + } + return cd; + } + +/* + * il_dflt - generate code for a defaulting conversion that always defaults. + */ +struct code *il_dflt(typcd, src, dflt, dest) +int typcd; +struct il_code *src; +struct il_c *dflt; +struct il_c *dest; + { + struct code *cd; + int sym_indx; + + sym_indx = src->u[0].n; + + if (typcd == TypCDbl) { + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "("; + cnv_dest(PrmDbl, 0, src, sym_indx, dest, cd, 1); /* variable */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = " = "; + sub_ilc(dflt, cd, 3); /* default */ + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ", 1)"; + } + else if (typcd == TypCInt || typcd == TypECInt) { + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "("; + cnv_dest(PrmInt, 0, src, sym_indx, dest, cd, 1); /* variable */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = " = "; + sub_ilc(dflt, cd, 3); /* default */ + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ", 1)"; + } + else if (typcd == TypTStr || typcd == str_typ) { + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "("; + cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = " = "; + sub_ilc(dflt, cd, 3); /* default */ + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ", 1)"; + } + else if (typcd == TypCStr) { + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "(AsgnCStr("; + cnv_dest(0, 1, src, sym_indx, dest, cd, 1); /* variable */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ", "; + sub_ilc(dflt, cd, 3); /* default */ + cd->ElemTyp(4) = A_Str; + cd->Str(4) = "), 1)"; + } + else if (typcd == TypTCset || typcd == cset_typ) { + cd = alc_ary(7); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "(BlkLoc("; + cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ") = (union block *)&"; + sub_ilc(dflt, cd, 3); /* default */ + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ", "; + cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */ + cd->ElemTyp(6) = A_Str; + cd->Str(6) = ".dword = D_Cset, 1)"; + } + else if (typcd == TypEInt || typcd == int_typ) { + cd = alc_ary(7); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "(IntVal("; + cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ") = "; + sub_ilc(dflt, cd, 3); /* default */ + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ", "; + cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */ + cd->ElemTyp(6) = A_Str; + cd->Str(6) = ".dword = D_Integer, 1)"; + } + else if (typcd == real_typ) { + cd = alc_ary(7); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "((BlkLoc("; + cnv_dest(0, 0, src, sym_indx, dest, cd, 1); /* variable */ + cd->ElemTyp(2) = A_Str; + cd->Str(2) = ") = (union block *)alcreal("; + sub_ilc(dflt, cd, 3); /* default */ + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ")) == NULL ? (fatalerr(0,NULL), 0) : ("; + cnv_dest(0, 0, src, sym_indx, dest, cd, 5); /* variable */ + cd->ElemTyp(6) = A_Str; + cd->Str(6) = ".dword = D_Real, 1))"; + } + + return cd; + } + +/* + * cnv_dest - output the destination of a conversion. + */ +static void cnv_dest(loc, is_cstr, src, sym_indx, dest, cd, i) +int loc; +int is_cstr; +struct il_code *src; +int sym_indx; +struct il_c *dest; +struct code *cd; +int i; + { + if (dest == NULL) { + /* + * Convert "in place", changing the location of a parameter if needed. + */ + switch (loc) { + case PrmInt: + if (cur_symtab[sym_indx].itmp_indx < 0) + cur_symtab[sym_indx].itmp_indx = alc_itmp(intrnl_lftm); + cur_symtab[sym_indx].loc = itmp_loc(cur_symtab[sym_indx].itmp_indx); + break; + case PrmDbl: + if (cur_symtab[sym_indx].dtmp_indx < 0) + cur_symtab[sym_indx].dtmp_indx = alc_dtmp(intrnl_lftm); + cur_symtab[sym_indx].loc = dtmp_loc(cur_symtab[sym_indx].dtmp_indx); + break; + } + il_var(src, cd, i); + if (is_cstr) + cur_symtab[sym_indx].loc = loc_cpy(cur_symtab[sym_indx].loc,M_CharPtr); + } + else { + if (is_cstr && dest->il_c_type == ILC_Mod && dest->next == NULL && + dest->n != RsltIndx && cur_symtab[dest->n].loc->mod_access != M_None) { + /* + * We are converting to a C string. The destination variable + * is not defined as a simple descriptor, but must be accessed + * as such for this conversion. + */ + cd->ElemTyp(i) = A_ValLoc; + cd->ValLoc(i) = loc_cpy(cur_symtab[dest->n].loc, M_None); + } + else + sub_ilc(dest, cd, i); + } + + } + +/* + * il_copy - produce code for an optimized "conversion" that always succeeds + * and just copies a value from one place to another. + */ +struct code *il_copy(dest, src) +struct il_c *dest; +struct val_loc *src; + { + struct code *cd; + + cd = alc_ary(5); + cd->ElemTyp(0) = A_Str; + cd->Str(0) = "("; + sub_ilc(dest, cd, 1); + cd->ElemTyp(2) = A_Str; + cd->Str(2) = " = "; + cd->ElemTyp(3) = A_ValLoc; + cd->ValLoc(3) = src; + cd->ElemTyp(4) = A_Str; + cd->Str(4) = ", 1)"; + return cd; + } + +/* + * loc_cpy - make a copy of a reference to a value location, but change + * the way the location is accessed. + */ +struct val_loc *loc_cpy(loc, mod_access) +struct val_loc *loc; +int mod_access; + { + struct val_loc *new_loc; + + if (loc == NULL) + return NULL; + new_loc = NewStruct(val_loc); + *new_loc = *loc; + new_loc->mod_access = mod_access; + return new_loc; + } + +/* + * gen_tcase - generate in-line code for a type_case statement. + */ +static int gen_tcase(il, has_dflt) +struct il_code *il; +int has_dflt; + { + struct case_anlz case_anlz; + + /* + * We can only get here if the type_case statement can be implemented + * with a no more than one type check. Determine how simple the + * code can be. + */ + findcases(il, has_dflt, &case_anlz); + if (case_anlz.il_then == NULL) { + if (case_anlz.il_else == NULL) + return 1; + else + return gen_il(case_anlz.il_else); + } + else + return gen_if(typ_chk(il->u[0].fld, case_anlz.typcd), case_anlz.il_then, + case_anlz.il_else, sav_locs()); + } + +/* + * gen_if - generate code to test a condition that might be true + * of false. Determine if execution can continue past this if statement. + */ +static int gen_if(cond_cd, il_then, il_else, locs) +struct code *cond_cd; +struct il_code *il_then; +struct il_code *il_else; +struct val_loc **locs; + { + struct val_loc **locs1; + struct code *lbl_then; + struct code *lbl_end; + struct code *else_loc; + struct code *cd; + int fall_thru; + + lbl_then = oper_lbl("then"); + lbl_end = oper_lbl("end if"); + cd = NewCode(2); + cd->cd_id = C_If; + cd->Cond = cond_cd; + cd->ThenStmt = mk_goto(lbl_then); + cd_add(cd); + else_loc = cur_fnc->cursor; + cd_add(lbl_then); + fall_thru = gen_il(il_then); + cd_add(lbl_end); + locs1 = sav_locs(); + rstr_locs(locs); + cur_fnc->cursor = else_loc; /* go back for the else clause */ + fall_thru |= gen_il(il_else); + cd_add(mk_goto(lbl_end)); + cur_fnc->cursor = lbl_end; + mrg_locs(locs1); + return fall_thru; + } diff --git a/src/iconc/ivalues.c b/src/iconc/ivalues.c new file mode 100644 index 0000000..4fbb288 --- /dev/null +++ b/src/iconc/ivalues.c @@ -0,0 +1,51 @@ +/* + * ivalues.c - routines for manipulating Icon values. + */ +#include "../h/gsupport.h" +#include "ctrans.h" +#include "csym.h" +#include "ctree.h" +#include "ccode.h" +#include "cproto.h" +#include "cglobals.h" + + +/* + * iconint - convert the string representation of an Icon integer to a C long. + * Return -1 if the number is too big and large integers are supported. + */ +long iconint(image) +char *image; + { + register int c; + register int r; + register char *s; + long n, n1; + int overflow; + + s = image; + overflow = 0; + n = 0L; + while ((c = *s++) >= '0' && c <= '9') { + n1 = n * 10 + (c - '0'); + if (n != n1 / 10) + overflow = 1; + n = n1; + } + if (c == 'r' || c == 'R') { + r = n; + n = 0L; + while ((c = *s++) != '\0') { + n1 = n * r + tonum(c); + if (n != n1 / r) + overflow = 1; + n = n1; + } + } + if (overflow) + if (largeints) + n = -1; + else + tfatal("large integer option required", image); + return n; + } diff --git a/src/iconc/lifetime.c b/src/iconc/lifetime.c new file mode 100644 index 0000000..9a4a7b5 --- /dev/null +++ b/src/iconc/lifetime.c @@ -0,0 +1,496 @@ +/* + * lifetime.c - perform liveness analysis to determine lifetime of intermediate + * results. + */ +#include "../h/gsupport.h" +#include "../h/lexdef.h" +#include "ctrans.h" +#include "cglobals.h" +#include "ctree.h" +#include "ctoken.h" +#include "csym.h" +#include "ccode.h" +#include "cproto.h" + +/* + * Prototypes for static functions. + */ +static void arg_life (nodeptr n, long min_result, long max_result, + int resume, int frst_arg, int nargs, nodeptr resumer, + nodeptr *failer, int *gen); + +static int postn = -1; /* relative position in execution order (all neg) */ + +/* + * liveness - compute lifetimes of intermediate results. + */ +void liveness(n, resumer, failer, gen) +nodeptr n; +nodeptr resumer; +nodeptr *failer; +int *gen; + { + struct loop { + nodeptr resumer; + int gen; + nodeptr lifetime; + int every_cntrl; + struct loop *prev; + } loop_info; + struct loop *loop_sav; + static struct loop *cur_loop = NULL; + nodeptr failer1; + nodeptr failer2; + int gen1 = 0; + int gen2 = 0; + struct node *cases; + struct node *clause; + long min_result; /* minimum result sequence length */ + long max_result; /* maximum result sequence length */ + int resume; /* flag - resumption possible after last result */ + + n->postn = postn--; + + switch (n->n_type) { + case N_Activat: + /* + * Activation can fail or succeed. + */ + arg_life(n, 0L, 1L, 0, 1, 2, resumer, failer, gen); + break; + + case N_Alt: + Tree1(n)->lifetime = n->lifetime; + Tree0(n)->lifetime = n->lifetime; + liveness(Tree1(n), resumer, &failer2, &gen2); + liveness(Tree0(n), resumer, &failer1, &gen1); + *failer = failer2; + *gen = 1; + break; + + case N_Apply: + /* + * Assume operation can suspend or fail. + */ + arg_life(n, 0L, UnbndSeq, 1, 0, 2, resumer, failer, gen); + break; + + case N_Augop: + /* + * Impl0(n) is assignment. Impl1(n) is the augmented operation. + */ + min_result = Impl0(n)->min_result * Impl1(n)->min_result; + max_result = Impl0(n)->max_result * Impl1(n)->max_result; + resume = Impl0(n)->resume | Impl1(n)->resume; + arg_life(n, min_result, max_result, resume, 2, 2, resumer, failer, + gen); + break; + + case N_Bar: + if (resumer == NULL) + n->intrnl_lftm = n; + else + n->intrnl_lftm = resumer; + Tree0(n)->lifetime = n->lifetime; + liveness(Tree0(n), resumer, failer, &gen1); + *gen = 1; + break; + + case N_Break: + if (cur_loop == NULL) { + nfatal(n, "invalid context for break", NULL); + return; + } + Tree0(n)->lifetime = cur_loop->lifetime; + loop_sav = cur_loop; + cur_loop = cur_loop->prev; + liveness(Tree0(n), loop_sav->resumer, &failer1, &gen1); + cur_loop = loop_sav; + cur_loop->gen |= gen1; + *failer = NULL; + *gen = 0; + break; + + case N_Case: + *failer = resumer; + *gen = 0; + + cases = Tree1(n); + while (cases != NULL) { + if (cases->n_type == N_Ccls) { + clause = cases; + cases = NULL; + } + else { + clause = Tree1(cases); + cases = Tree0(cases); + } + + /* + * Body. + */ + Tree1(clause)->lifetime = n->lifetime; + liveness(Tree1(clause), resumer, &failer2, &gen2); + if (resumer == NULL && failer2 != NULL) + *failer = n; + *gen |= gen2; + + /* + * The expression being compared can be resumed. + */ + Tree0(clause)->lifetime = clause; + liveness(Tree0(clause), clause, &failer1, &gen1); + } + + if (Tree2(n) == NULL) { + if (resumer == NULL) + *failer = n; + } + else { + Tree2(n)->lifetime = n->lifetime; + liveness(Tree2(n), resumer, &failer2, &gen2); /* default */ + if (resumer == NULL && failer2 != NULL) + *failer = n; + *gen |= gen2; + } + + /* + * control clause is bounded + */ + Tree0(n)->lifetime = n; + liveness(Tree0(n), NULL, &failer1, &gen1); + if (failer1 != NULL && *failer == NULL) + *failer = failer1; + break; + + case N_Create: + Tree0(n)->lifetime = n; + loop_sav = cur_loop; + cur_loop = NULL; /* check for invalid break and next */ + liveness(Tree0(n), n, &failer1, &gen1); + cur_loop = loop_sav; + *failer = NULL; + *gen = 0; + break; + + case N_Cset: + case N_Empty: + case N_Id: + case N_Int: + case N_Real: + case N_Str: + *failer = resumer; + *gen = 0; + break; + + case N_Field: + Tree0(n)->lifetime = n; + liveness(Tree0(n), resumer, failer, gen); + break; + + case N_If: + Tree1(n)->lifetime = n->lifetime; + liveness(Tree1(n), resumer, failer, gen); + if (Tree2(n)->n_type != N_Empty) { + Tree2(n)->lifetime = n->lifetime; + liveness(Tree2(n), resumer, &failer2, &gen2); + if (failer2 != NULL) { + if (*failer == NULL) + *failer = failer2; + else { + if ((*failer)->postn < failer2->postn) + *failer = failer2; + if ((*failer)->postn < n->postn) + *failer = n; + } + } + *gen |= gen2; + } + /* + * control clause is bounded + */ + Tree0(n)->lifetime = NULL; + liveness(Tree0(n), NULL, &failer1, &gen1); + if (Tree2(n)->n_type == N_Empty && failer1 != NULL && *failer == NULL) + *failer = failer1; + break; + + case N_Invok: + /* + * Assume operation can suspend and fail. + */ + arg_life(n, 0L, UnbndSeq, 1, 1, Val0(n) + 1, resumer, failer, gen); + break; + + case N_InvOp: + arg_life(n, Impl1(n)->min_result, Impl1(n)->max_result, + Impl1(n)->resume, 2, Val0(n), resumer, failer, gen); + break; + + case N_InvProc: + if (Proc1(n)->ret_flag & DoesFail) + min_result = 0L; + else + min_result = 1L; + if (Proc1(n)->ret_flag & DoesSusp) { + max_result = UnbndSeq; + resume = 1; + } + else { + max_result = 1L; + resume = 0; + } + arg_life(n, min_result, max_result, resume, 2, Val0(n), resumer, + failer, gen); + break; + + case N_InvRec: + arg_life(n, err_conv ? 0L : 1L, 1L, 1, 2, Val0(n), resumer, failer, + gen); + break; + + case N_Limit: + if (resumer == NULL) + n->intrnl_lftm = n; + else + n->intrnl_lftm = resumer; + Tree0(n)->lifetime = n->lifetime; + liveness(Tree0(n), resumer, &failer1, &gen1); + Tree1(n)->lifetime = n; + liveness(Tree1(n), failer1 == NULL ? n : failer1, &failer2, &gen2); + *failer = failer2; + *gen = gen1 | gen2; + break; + + case N_Loop: { + loop_info.prev = cur_loop; + loop_info.resumer = resumer; + loop_info.gen = 0; + loop_info.every_cntrl = 0; + loop_info.lifetime = n->lifetime; + cur_loop = &loop_info; + switch ((int)Val0(Tree0(n))) { + case EVERY: + /* + * The body is bounded. The control clause is resumed + * by the control structure. + */ + Tree2(n)->lifetime = NULL; + liveness(Tree2(n), NULL, &failer2, &gen2); + loop_info.every_cntrl = 1; + Tree1(n)->lifetime = NULL; + liveness(Tree1(n), n, &failer1, &gen1); + break; + + case REPEAT: + /* + * The body is bounded. + */ + Tree1(n)->lifetime = NULL; + liveness(Tree1(n), NULL, &failer1, &gen1); + break; + + case SUSPEND: + /* + * The body is bounded. The control clause is resumed + * by the control structure. + */ + Tree2(n)->lifetime = NULL; + liveness(Tree2(n), NULL, &failer2, &gen2); + loop_info.every_cntrl = 1; + Tree1(n)->lifetime = n; + liveness(Tree1(n), n, &failer1, &gen1); + break; + + case WHILE: + case UNTIL: + /* + * The body and the control clause are each bounded. + */ + Tree2(n)->lifetime = NULL; + liveness(Tree2(n), NULL, &failer1, &gen1); + Tree1(n)->lifetime = NULL; + liveness(Tree1(n), NULL, &failer1, &gen1); + break; + } + *failer = (resumer == NULL ? n : resumer); /* assume a loop can fail */ + *gen = cur_loop->gen; + cur_loop = cur_loop->prev; + } + break; + + case N_Next: + if (cur_loop == NULL) { + nfatal(n, "invalid context for next", NULL); + return; + } + if (cur_loop->every_cntrl) + *failer = n; + else + *failer = NULL; + *gen = 0; + break; + + case N_Not: + /* + * The expression is bounded. + */ + Tree0(n)->lifetime = NULL; + liveness(Tree0(n), NULL, &failer1, &gen1); + *failer = (resumer == NULL ? n : resumer); + *gen = 0; + break; + + case N_Ret: + if (Val0(Tree0(n)) == RETURN) { + /* + * The expression is bounded. + */ + Tree1(n)->lifetime = n; + liveness(Tree1(n), NULL, &failer1, &gen1); + } + *failer = NULL; + *gen = 0; + break; + + case N_Scan: { + struct implement *asgn_impl; + + if (resumer == NULL) + n->intrnl_lftm = n; + else + n->intrnl_lftm = resumer; + + if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) { + asgn_impl = optab[asgn_loc].binary; + arg_life(n, asgn_impl->min_result, asgn_impl->max_result, + asgn_impl->resume, 1, 2, resumer, failer, gen); + } + else { + Tree2(n)->lifetime = n->lifetime; + liveness(Tree2(n), resumer, &failer2, &gen2); /* body */ + Tree1(n)->lifetime = n; + liveness(Tree1(n), failer2, &failer1, &gen1); /* subject */ + *failer = failer1; + *gen = gen1 | gen2; + } + } + break; + + case N_Sect: + /* + * Impl0(n) is sectioning. + */ + min_result = Impl0(n)->min_result; + max_result = Impl0(n)->max_result; + resume = Impl0(n)->resume; + if (Impl1(n) != NULL) { + /* + * Impl1(n) is plus or minus. + */ + min_result *= Impl1(n)->min_result; + max_result *= Impl1(n)->max_result; + resume |= Impl1(n)->resume; + } + arg_life(n, min_result, max_result, resume, 2, 3, resumer, failer, + gen); + break; + + case N_Slist: + /* + * expr1 is not bounded, expr0 is bounded. + */ + Tree1(n)->lifetime = n->lifetime; + liveness(Tree1(n), resumer, failer, gen); + Tree0(n)->lifetime = NULL; + liveness(Tree0(n), NULL, &failer1, &gen1); + break; + + case N_SmplAsgn: + Tree3(n)->lifetime = n; + liveness(Tree3(n), resumer, failer, gen); /* 2nd operand */ + Tree2(n)->lifetime = n->lifetime; /* may be result of := */ + liveness(Tree2(n), *failer, &failer1, &gen1); /* 1st operand */ + break; + + case N_SmplAug: + /* + * Impl1(n) is the augmented operation. + */ + arg_life(n, Impl1(n)->min_result, Impl1(n)->max_result, + Impl1(n)->resume, 2, 2, resumer, failer, gen); + break; + + default: + fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); + exit(EXIT_FAILURE); + } + } + +/* + * arg_life - compute the lifetimes of an argument list. + */ +static void arg_life(n, min_result, max_result, resume, frst_arg, nargs, + resumer, failer, gen) +nodeptr n; +long min_result; /* minimum result sequence length */ +long max_result; /* maximum result sequence length */ +int resume; /* flag - resumption possible after last result */ +int frst_arg; +int nargs; +nodeptr resumer; +nodeptr *failer; +int *gen; + { + nodeptr failer1; + nodeptr failer2; + nodeptr lifetime; + int inv_fail; /* failure after operation in invoked */ + int reuse; + int gen2; + int i; + + /* + * Determine what, if anything, can resume the rightmost argument. + */ + if (resumer == NULL && min_result == 0) + failer1 = n; + else + failer1 = resumer; + if (failer1 == NULL) + inv_fail = 0; + else + inv_fail = 1; + + /* + * If the operation can be resumed, variables internal to the operation + * have and extended lifetime. + */ + if (resumer != NULL && (max_result > 1 || max_result == UnbndSeq || resume)) + n->intrnl_lftm = resumer; + else + n->intrnl_lftm = n; + + /* + * Go through the parameter list right to left, propagating resumption + * information, computing lifetimes, and determining whether anything + * can generate. + */ + lifetime = n; + reuse = 0; + *gen = 0; + for (i = frst_arg + nargs - 1; i >= frst_arg; --i) { + n->n_field[i].n_ptr->lifetime = lifetime; + n->n_field[i].n_ptr->reuse = reuse; + liveness(n->n_field[i].n_ptr, failer1, &failer2, &gen2); + if (resumer != NULL && gen2) + lifetime = resumer; + if (inv_fail && gen2) + reuse = 1; + failer1 = failer2; + *gen |= gen2; + } + *failer = failer1; + if (max_result > 1 || max_result == UnbndSeq) + *gen = 1; + } diff --git a/src/iconc/types.c b/src/iconc/types.c new file mode 100644 index 0000000..cd3a3ef --- /dev/null +++ b/src/iconc/types.c @@ -0,0 +1,893 @@ +/* + * typinfer.c - routines to perform type inference. + */ +#include "../h/gsupport.h" +#include "../h/lexdef.h" +#include "ctrans.h" +#include "csym.h" +#include "ctree.h" +#include "ctoken.h" +#include "cglobals.h" +#include "ccode.h" +#include "cproto.h" +#ifdef TypTrc +#ifdef HighResTime +#include +#include +#endif /* HighResTime */ +#endif /* TypTrc */ + +extern unsigned int null_bit; /* bit for null type */ +extern unsigned int str_bit; /* bit for string type */ +extern unsigned int cset_bit; /* bit for cset type */ +extern unsigned int int_bit; /* bit for integer type */ +extern unsigned int real_bit; /* bit for real type */ +extern unsigned int n_icntyp; /* number of non-variable types */ +extern unsigned int n_intrtyp; /* number of types in intermediate values */ +extern unsigned int val_mask; /* mask for non-var types in last int of type*/ +extern struct typ_info *type_array; + +/* + * free_struct_typinfo - frees a struct typinfo structure by placing + * it one a list of free structures + */ +#ifdef OptimizeType +extern struct typinfo *start_typinfo; +extern struct typinfo *high_typinfo; +extern struct typinfo *low_typinfo; +extern struct typinfo *free_typinfo; + +void free_struct_typinfo(struct typinfo *typ) { + + typ->bits = (unsigned int *)free_typinfo; + free_typinfo = typ; +} +#endif /* OptimizeType */ + +/* + * alloc_typ - allocate a compressed type structure and initializes + * the members to zero or NULL. + */ +#ifdef OptimizeType +struct typinfo *alloc_typ(n_types) +#else /* OptimizeType */ +unsigned int *alloc_typ(n_types) +#endif /* OptimizeType */ +int n_types; +{ +#ifdef OptimizeType + struct typinfo *typ; + int i; + unsigned int init = 0; + + if ((free_typinfo == NULL) && (high_typinfo == low_typinfo)) { + /* + * allocate a large block of memory used to parcel out struct typinfo + * structures from + */ + start_typinfo = (struct typinfo *)alloc(sizeof(struct typinfo) * TYPINFO_BLOCK); + high_typinfo = start_typinfo; + low_typinfo = start_typinfo + TYPINFO_BLOCK; + free_typinfo = NULL; + typ = start_typinfo; + high_typinfo++; + } + else if (free_typinfo != NULL) { + /* + * get a typinfo stucture from the list of free structures + */ + typ = free_typinfo; + free_typinfo = (struct typinfo *)free_typinfo->bits; + } + else { + /* + * get a typinfo structure from the chunk of memory allocated + * previously + */ + typ = high_typinfo; + high_typinfo++; + } + typ->packed = n_types; + if (!do_typinfer) + typ->bits = alloc_mem_typ(n_types); + else + typ->bits= NULL; + return typ; +#else /* OptimizeType */ + int n_ints; + unsigned int *typ; + int i; + unsigned int init = 0; + + n_ints = NumInts(n_types); + typ = (unsigned int *)alloc((unsigned int)((n_ints)*sizeof(unsigned int))); + + /* + * Initialization: if we are doing inference, start out assuming no types. + * If we are not doing inference, assume any type. + */ + if (!do_typinfer) + init = ~init; + for (i = 0; i < n_ints; ++i) + typ[i] = init; + return typ; +#endif /* OptimizeType */ +} + +/* + * alloc_mem_typ - actually allocates a full sized bit vector. + */ +#ifdef OptimizeType +unsigned int *alloc_mem_typ(n_types) +unsigned int n_types; +{ + int n_ints; + unsigned int *typ; + int i; + unsigned int init = 0; + + n_ints = NumInts(n_types); + typ = (unsigned int *)alloc((unsigned int)((n_ints)*sizeof(unsigned int))); + if (!do_typinfer) + init = ~init; + for(i=0; i < n_ints ;++i) + typ[i] = init; + return typ; +} +#endif /* OptimizeType */ + +/* + * set_typ - set a particular type bit in a type bit vector. + */ +void set_typ(type, bit) +#ifdef OptimizeType +struct typinfo *type; +#else /* OptimizeType */ +unsigned int *type; +#endif /* OptimizeType */ +unsigned int bit; +{ + unsigned int indx; + unsigned int mask; + +#ifdef OptimizeType + if (type->bits == NULL) { + if (bit == null_bit) + type->packed |= NULL_T; + else if (bit == real_bit) + type->packed |= REAL_T; + else if (bit == int_bit) + type->packed |= INT_T; + else if (bit == cset_bit) + type->packed |= CSET_T; + else if (bit == str_bit) + type->packed |= STR_T; + else { + /* + * if the bit to set is not one of the five builtin types + * then allocate a whole bit vector, copy the packed + * bits over, and set the requested bit + */ + type->bits = alloc_mem_typ(DecodeSize(type->packed)); + xfer_packed_types(type); + indx = bit / IntBits; + mask = 1; + mask <<= bit % IntBits; + type->bits[indx] |= mask; + } + } + else { + indx = bit / IntBits; + mask = 1; + mask <<= bit % IntBits; + type->bits[indx] |= mask; + } +#else /* OptimizeType */ + indx = bit / IntBits; + mask = 1; + mask <<= bit % IntBits; + type[indx] |= mask; +#endif /* OptimizeType */ +} + +/* + * clr_type - clear a particular type bit in a type bit vector. + */ +void clr_typ(type, bit) +#ifdef OptimizeType +struct typinfo *type; +#else /* OptimizeType */ +unsigned int *type; +#endif /* OptimizeType */ +unsigned int bit; +{ + unsigned int indx; + unsigned int mask; + +#ifdef OptimizeType + if (type->bits == NULL) { + /* + * can only clear one of five builtin types + */ + if (bit == null_bit) + type->packed &= ~NULL_T; + else if (bit == real_bit) + type->packed &= ~REAL_T; + else if (bit == int_bit) + type->packed &= ~INT_T; + else if (bit == cset_bit) + type->packed &= ~CSET_T; + else if (bit == str_bit) + type->packed &= ~STR_T; + } + else { + /* + * build bit mask to clear requested type in full bit vector + */ + indx = bit / IntBits; + mask = 1; + mask <<= bit % IntBits; + type->bits[indx] &= ~mask; + } +#else /* OptimizeType */ + indx = bit / IntBits; + mask = 1; + mask <<= bit % IntBits; + type[indx] &= ~mask; +#endif /* OptimizeType */ +} + +/* + * has_type - determine if a bit vector representing types has any bits + * set that correspond to a specific type code from the data base. Also, + * if requested, clear any such bits. + */ +int has_type(typ, typcd, clear) +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ +int typcd; +int clear; +{ + int frst_bit, last_bit; + int i; + int found; + + found = 0; + bitrange(typcd, &frst_bit, &last_bit); + for (i = frst_bit; i < last_bit; ++i) { + if (bitset(typ, i)) { + found = 1; + if (clear) + clr_typ(typ, i); + } + } + return found; +} + +/* + * other_type - determine if a bit vector representing types has any bits + * set that correspond to a type *other* than specific type code from the + * data base. + */ +int other_type(typ, typcd) +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ +int typcd; + { + int frst_bit, last_bit; + int i; + + bitrange(typcd, &frst_bit, &last_bit); + for (i = 0; i < frst_bit; ++i) + if (bitset(typ, i)) + return 1; + for (i = last_bit; i < n_intrtyp; ++i) + if (bitset(typ, i)) + return 1; + return 0; + } + +/* + * bitrange - determine the range of bit positions in a type bit vector + * that correspond to a type code from the data base. + */ +void bitrange(typcd, frst_bit, last_bit) +int typcd; +int *frst_bit; +int *last_bit; + { + if (typcd == TypVar) { + /* + * All variable types. + */ + *frst_bit = n_icntyp; + *last_bit = n_intrtyp; + } + else { + *frst_bit = type_array[typcd].frst_bit; + *last_bit = *frst_bit + type_array[typcd].num_bits; + } + } + +/* + * typcd_bits - set the bits of a bit vector corresponding to a type + * code from the data base. + */ +void typcd_bits(typcd, typ) +int typcd; +struct type *typ; + { + int frst_bit; + int last_bit; + int i; + + if (typcd == TypEmpty) + return; /* Do nothing. */ + + if (typcd == TypAny) { + /* + * Set bits corresponding to first-class types. + */ +#ifdef OptimizeType + /* + * allocate a full bit vector and copy over packed types first + */ + if (typ->bits->bits == NULL) { + typ->bits->bits = alloc_mem_typ(DecodeSize(typ->bits->packed)); + xfer_packed_types(typ->bits); + } + for (i = 0; i < NumInts(n_icntyp) - 1; ++i) + typ->bits->bits[i] |= ~(unsigned int)0; + typ->bits->bits[i] |= val_mask; +#else /* OptimizeType */ + for (i = 0; i < NumInts(n_icntyp) - 1; ++i) + typ->bits[i] |= ~(unsigned int)0; + typ->bits[i] |= val_mask; +#endif /* OptimizeType */ + return; + } + + bitrange(typcd, &frst_bit, &last_bit); +#ifdef OptimizeType + if (last_bit > DecodeSize(typ->bits->packed)) /* bad abstract type computation */ + return; +#endif /* OptimizeType */ + for (i = frst_bit; i < last_bit; ++i) + set_typ(typ->bits, i); + } + +/* + * bitset - determine if a specific bit in a bit vector is set. + */ +int bitset(typ, bit) +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ +int bit; +{ + int mask; + int indx; + +#ifdef OptimizeType + if (typ->bits == NULL) { + /* + * check to see if the requested bit is set in the packed representation + * if the requested bit is not one of the five builtins then the + * lookup fails no matter what + */ + if (bit == null_bit) + return (typ->packed & NULL_T); + else if (bit == real_bit) + return (typ->packed & REAL_T); + else if (bit == int_bit) + return (typ->packed & INT_T); + else if (bit == cset_bit) + return (typ->packed & CSET_T); + else if (bit == str_bit) + return (typ->packed & STR_T); + else + return 0; + } + else { + /* + * create a mask to check to see if the requested type bit is + * set on + */ + indx = bit / IntBits; + mask = 1; + mask <<= bit % IntBits; + return typ->bits[indx] & mask; + } +#else /* OptimizeType */ + indx = bit / IntBits; + mask = 1; + mask <<= bit % IntBits; + return typ[indx] & mask; +#endif /* OptimizeType */ +} + +/* + * is_empty - determine if a type bit vector is empty. + */ +int is_empty(typ) +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ +{ + int i; + +#ifdef OptimizeType + if (typ->bits == NULL) { + /* + * if any bits are set on then the vector is not empty + */ + if (DecodePacked(typ->packed)) + return 0; + else + return 1; + } + else { + for (i = 0; i < NumInts(n_intrtyp); ++i) { + if (typ->bits[i] != 0) + return 0; + } + return 1; + } +#else /* OptimizeType */ + for (i = 0; i < NumInts(n_intrtyp); ++i) { + if (typ[i] != 0) + return 0; + } + return 1; +#endif /* OptimizeType */ +} + +/* + * xfer_packed_types - transfers the packed type representation + * to a full length bit vector representation in the same + * struct typinfo structure. + */ +#ifdef OptimizeType +void xfer_packed_types(type) +struct typinfo *type; +{ + unsigned int indx, mask; + + /* + * for each IF statement built a mask to set each of the five builtins + * if they are present in the packed representation + */ + if (type->packed & NULL_T) { + indx = null_bit / IntBits; + mask = 1; + mask <<= null_bit % IntBits; + type->bits[indx] |= mask; + } + if (type->packed & REAL_T) { + indx = real_bit / IntBits; + mask = 1; + mask <<= real_bit % IntBits; + type->bits[indx] |= mask; + } + if (type->packed & INT_T) { + indx = int_bit / IntBits; + mask = 1; + mask <<= int_bit % IntBits; + type->bits[indx] |= mask; + } + if (type->packed & CSET_T) { + indx = cset_bit / IntBits; + mask = 1; + mask <<= cset_bit % IntBits; + type->bits[indx] |= mask; + } + if (type->packed & STR_T) { + indx = str_bit / IntBits; + mask = 1; + mask <<= str_bit % IntBits; + type->bits[indx] |= mask; + } +} + +/* + * xfer_packed_to_bits - sets those type bits from the src typinfo structure + * to the dest typinfo structure AND the src is a packed representation + * while the dest is a bit vector. Returns the number of new bits that + * were set in the destination. + */ +int xfer_packed_to_bits(src, dest, nsize) +struct typinfo *src; +struct typinfo *dest; +int nsize; +{ + unsigned int indx, mask, old, rnsize; + int changes[5] = {-1,-1,-1,-1,-1}; + int ix, membr = 0, i; + + ix = 0; + rnsize = NumInts(nsize); + /* + * for each possible type set in the packed vector, create a mask + * and apply it to the dest. check to see if there was actually + * a change in the dest vector. + */ + if (src->packed & NULL_T) { + indx = null_bit / IntBits; + if (indx < rnsize) { + mask = 1; + mask <<= null_bit % IntBits; + old = dest->bits[indx]; + dest->bits[indx] |= mask; + if (old != dest->bits[indx]) { + membr = 0; + for (i=0; i < 5 ;i++) + /* + * checks to see if the bit just set happens to be in the + * same word as any other of the five builtins. if they + * are then we only want to count this as one change + */ + if (indx == changes[i]) { + membr = 1; break; + } + if (!membr) + changes[ix++] = indx; + } + } + } + if (src->packed & REAL_T) { + indx = real_bit / IntBits; + if (indx < rnsize) { + mask = 1; + mask <<= real_bit % IntBits; + old = dest->bits[indx]; + dest->bits[indx] |= mask; + if (old != dest->bits[indx]) { + membr = 0; + for (i=0; i < 5 ;i++) + if (indx == changes[i]) { + membr = 1; break; + } + if (!membr) + changes[ix++] = indx; + } + } + } + if (src->packed & INT_T) { + indx = int_bit / IntBits; + if (indx < rnsize) { + mask = 1; + mask <<= int_bit % IntBits; + old = dest->bits[indx]; + dest->bits[indx] |= mask; + if (old != dest->bits[indx]) { + membr = 0; + for (i=0; i < 5 ;i++) + if (indx == changes[i]) { + membr = 1; break; + } + if (!membr) + changes[ix++] = indx; + } + } + } + if (src->packed & CSET_T) { + indx = cset_bit / IntBits; + if (indx < rnsize) { + mask = 1; + mask <<= cset_bit % IntBits; + old = dest->bits[indx]; + dest->bits[indx] |= mask; + if (old != dest->bits[indx]) { + membr = 0; + for (i=0; i < 5 ;i++) + if (indx == changes[i]) { + membr = 1; break; + } + if (!membr) + changes[ix++] = indx; + } + } + } + if (src->packed & STR_T) { + indx = str_bit / IntBits; + if (indx < rnsize) { + mask = 1; + mask <<= str_bit % IntBits; + old = dest->bits[indx]; + dest->bits[indx] |= mask; + if (old != dest->bits[indx]) { + membr = 0; + for (i=0; i < 5 ;i++) + if (indx == changes[i]) { + membr = 1; break; + } + if (!membr) + changes[ix++] = indx; + } + } + } + return ix; +} + +/* + * and_bits_to_packed - performs a bitwise AND of two typinfo structures + * taking into account of packed or full bit representation. + */ +void and_bits_to_packed(src, dest, size) +struct typinfo *src; +struct typinfo *dest; +int size; +{ + unsigned int indx, mask, val, destsz; + int i; + + if ((src->bits == NULL) && (dest->bits == NULL)) + /* Both are packed */ + dest->packed &= (0xFF000000 | src->packed); + else if ((src->bits == NULL) && (dest->bits != NULL)) { + /* + * built a bit mask for each type in the src and AND it too + * the bit vector in dest + */ + for (i=0; i < NumInts(size) ;i++) { + val = get_bit_vector(src,i); + dest->bits[i] &= val; + } + } + else if ((src->bits != NULL) && (dest->bits == NULL)) { + /* + * because an AND is being performed only those bits in the dest + * have the possibility of remaining set (i.e. five builtins) + * therefore if the bit is set in the packed check to see if + * it is also set in the full vector, if so then set it in the + * resulting vector, otherwise don't + */ + destsz = DecodeSize(dest->packed); + mask = 1; val = 0; + if (dest->packed & NULL_T) { + mask <<= (null_bit % IntBits); + if (src->bits[(null_bit/IntBits)] & mask) + val |= NULL_T; + } + mask = 1; + if (dest->packed & REAL_T) { + mask <<= (real_bit % IntBits); + if (src->bits[(real_bit/IntBits)] & mask) + val |= REAL_T; + } + mask = 1; + if (dest->packed & INT_T) { + mask <<= (int_bit % IntBits); + if (src->bits[(int_bit/IntBits)] & mask) + val |= INT_T; + } + mask = 1; + if (dest->packed & CSET_T) { + mask <<= (cset_bit % IntBits); + if (src->bits[(cset_bit/IntBits)] & mask) + val |= CSET_T; + } + mask = 1; + if (dest->packed & STR_T) { + mask <<= (str_bit % IntBits); + if (src->bits[(str_bit/IntBits)] & mask) + val |= STR_T; + } + dest->packed = val | destsz; + } + else + for (i=0; i < NumInts(size) ;i++) + dest->bits[i] &= src->bits[i]; +} + + +/* + * get_bit_vector - returns a bit mask from the selected word of a bit + * vector. e.g. if pos == 2, then check to see if any of the five + * builtins fall in the second word of a normal bit vector, if so + * create a bit mask with those types that fall in that word. + */ + +unsigned int get_bit_vector(src, pos) +struct typinfo *src; +int pos; +{ + unsigned int val = 0, mask; + + val = 0; + if ((src->packed & NULL_T) && ((null_bit / IntBits) == pos)) { + mask = 1; + mask <<= null_bit % IntBits; + val |= mask; + } + if ((src->packed & REAL_T) && ((real_bit / IntBits) == pos)) { + mask = 1; + mask <<= real_bit % IntBits; + val |= mask; + } + if ((src->packed & INT_T) && ((int_bit / IntBits) == pos)) { + mask = 1; + mask <<= int_bit % IntBits; + val |= mask; + } + if ((src->packed & CSET_T) && ((cset_bit / IntBits) == pos)) { + mask = 1; + mask <<= cset_bit % IntBits; + val |= mask; + } + if ((src->packed & STR_T) && ((str_bit / IntBits) == pos)) { + mask = 1; + mask <<= str_bit % IntBits; + val |= mask; + } + return val; +} + + +/* + * clr_packed - clears all bits within the nsize-th word for a packed + * representation. + */ + +void clr_packed(src, nsize) +struct typinfo *src; +int nsize; +{ + unsigned int rnsize; + + rnsize = NumInts(nsize); + if ((null_bit / IntBits) < rnsize) + src->packed &= ~NULL_T; + if ((real_bit / IntBits) < rnsize) + src->packed &= ~REAL_T; + if ((int_bit / IntBits) < rnsize) + src->packed &= ~INT_T; + if ((cset_bit / IntBits) < rnsize) + src->packed &= ~CSET_T; + if ((str_bit / IntBits) < rnsize) + src->packed &= ~STR_T; +} + +/* + * cpy_packed_to_packed - copies the packed bits from one bit vector + * to another. + */ + +void cpy_packed_to_packed(src, dest, nsize) +struct typinfo *src; +struct typinfo *dest; +int nsize; +{ + unsigned int indx, rnsize; + + rnsize = NumInts(nsize); + /* + * for each of the possible builtin types, check to see if the bit is + * set in the src and if present set it in the dest. + */ + dest->packed = DecodeSize(dest->packed); + if (src->packed & NULL_T) { + indx = null_bit / IntBits; + if (indx < rnsize) + dest->packed |= NULL_T; + } + if (src->packed & REAL_T) { + indx = real_bit / IntBits; + if (indx < rnsize) + dest->packed |= REAL_T; + } + if (src->packed & INT_T) { + indx = int_bit / IntBits; + if (indx < rnsize) + dest->packed |= INT_T; + } + if (src->packed & CSET_T) { + indx = cset_bit / IntBits; + if (indx < rnsize) + dest->packed |= CSET_T; + } + if (src->packed & STR_T) { + indx = str_bit / IntBits; + if (indx < rnsize) + dest->packed |= STR_T; + } +} + + +/* + * mrg_packed_to_packed - merges the packed type bits of a src and dest + * bit vector. + */ +int mrg_packed_to_packed(src, dest, nsize) +struct typinfo *src; +struct typinfo *dest; +int nsize; +{ + unsigned int indx, rnsize; + int changes[5] = {-1,-1,-1,-1,-1}; + int ix = 0, membr = 0, i; + + rnsize = NumInts(nsize); + /* + * for each of the five possible types in the src, check to see if it + * is set in the src and not set in the dest. if so then set it in + * the dest vector. + */ + if ((src->packed & NULL_T) && !(dest->packed & NULL_T)) { + indx = null_bit / IntBits; + if (indx < rnsize) { + dest->packed |= NULL_T; + for(i=0; i<5 ;i++) { + if (indx == changes[i]) { + membr = 1; break; + } + } + if (!membr) + changes[ix++] = indx; + } + } + if ((src->packed & REAL_T) && !(dest->packed & REAL_T)) { + indx = real_bit / IntBits; + if (indx < rnsize) { + dest->packed |= REAL_T; + for(i=0; i<5 ;i++) { + if (indx == changes[i]) { + membr = 1; break; + } + } + if (!membr) + changes[ix++] = indx; + } + } + if ((src->packed & INT_T) && !(dest->packed & INT_T)){ + indx = int_bit / IntBits; + if (indx < rnsize) { + dest->packed |= INT_T; + for(i=0; i<5 ;i++) { + if (indx == changes[i]) { + membr = 1; break; + } + } + if (!membr) + changes[ix++] = indx; + } + } + if ((src->packed & CSET_T) && !(dest->packed & CSET_T)) { + indx = cset_bit / IntBits; + if (indx < rnsize) { + dest->packed |= CSET_T; + for(i=0; i<5 ;i++) { + if (indx == changes[i]) { + membr = 1; break; + } + } + if (!membr) + changes[ix++] = indx; + } + } + if ((src->packed & STR_T) && !(dest->packed & STR_T)) { + indx = str_bit / IntBits; + if (indx < rnsize) { + dest->packed |= STR_T; + for(i=0; i<5 ;i++) { + if (indx == changes[i]) { + membr = 1; break; + } + } + if (!membr) + changes[ix++] = indx; + } + } + return ix; +} +#endif /* OptimizeType */ diff --git a/src/iconc/typinfer.c b/src/iconc/typinfer.c new file mode 100644 index 0000000..8a96e23 --- /dev/null +++ b/src/iconc/typinfer.c @@ -0,0 +1,5189 @@ +/* + * typinfer.c - routines to perform type inference. + */ +#include "../h/gsupport.h" +#include "../h/lexdef.h" +#include "ctrans.h" +#include "csym.h" +#include "ctree.h" +#include "ctoken.h" +#include "cglobals.h" +#include "ccode.h" +#include "cproto.h" +#ifdef TypTrc +#ifdef HighResTime +#include +#include +#endif /* HighResTime */ +#endif /* TypTrc */ + +/* + * Information about co-expressions is keep on a list. + */ +struct t_coexpr { + nodeptr n; /* code for co-expression */ + int typ_indx; /* relative type number (index) */ + struct store *in_store; /* store entry into co-expression via activation */ + struct store *out_store; /* store at end of co-expression */ +#ifdef OptimizeType + struct typinfo *act_typ; /* types passed via co-expression activation */ + struct typinfo *rslt_typ; /* types resulting from "co-expression return" */ +#else /* OptimizeType */ + unsigned int *act_typ; /* types passed via co-expression activation */ + unsigned int *rslt_typ; /* types resulting from "co-expression return" */ +#endif /* OptimizeType */ + int iteration; + struct t_coexpr *next; + }; + +struct t_coexpr *coexp_lst; + +#ifdef TypTrc +extern int typealloc; /* flag to account for allocation */ +extern long typespace; /* amount of space for type inference */ +#endif /* TypTrc */ + +struct symtyps *cur_symtyps; /* maps run-time routine symbols to types */ + +/* + * argtyps is the an array of types large enough to accommodate the argument + * list of any operation. + */ +struct argtyps { + struct argtyps *next; +#ifdef OptimizeType + struct typinfo *types[1]; /* actual size is max_prm */ +#else /* OptimizeType */ + unsigned int *types[1]; /* actual size is max_prm */ +#endif /* OptimizeType */ + }; + +/* + * prototypes for static functions. + */ +#ifdef OptimizeType +void and_bits_to_packed (struct typinfo *src, + struct typinfo *dest, int size); +struct typinfo *alloc_typ (int n_types); +unsigned int *alloc_mem_typ (unsigned int n_types); +int bitset (struct typinfo *typ, int bit); +void clr_typ (struct typinfo *type, unsigned int bit); +void clr_packed (struct typinfo *src, int nsize); +void cpy_packed_to_packed (struct typinfo *src, + struct typinfo *dest, int nsize); +static void deref_lcl (struct typinfo *src, + struct typinfo *dest); +static int findloops ( struct node *n, int resume, + struct typinfo *rslt_type); +static void gen_inv (struct typinfo *prc_typ, nodeptr n); +int has_type (struct typinfo *typ, int typcd, int clear); +static void infer_impl (struct implement *impl, + nodeptr n, struct symtyps *symtyps, + struct typinfo *rslt_typ); +int is_empty (struct typinfo *typ); +int mrg_packed_to_packed (struct typinfo *src, + struct typinfo *dest, int nsize); +int other_type (struct typinfo *typ, int typcd); +static void set_ret (struct typinfo *typ); +void set_typ (struct typinfo *type, unsigned int bit); +void typcd_bits (int typcd, struct type *typ); +static void typ_deref (struct typinfo *src, + struct typinfo *dest, int chk); +int xfer_packed_to_bits (struct typinfo *src, + struct typinfo *dest, int nsize); +#else /* OptimizeType */ +unsigned int *alloc_typ (int n_types); +int bitset (unsigned int *typ, int bit); +void clr_typ (unsigned int *type, unsigned int bit); +static void deref_lcl (unsigned int *src, unsigned int *dest); +static int findloops ( struct node *n, int resume, + unsigned int *rslt_type); +static void gen_inv (unsigned int *prc_typ, nodeptr n); +int has_type (unsigned int *typ, int typcd, int clear); +static void infer_impl (struct implement *impl, + nodeptr n, struct symtyps *symtyps, + unsigned int *rslt_typ); +int is_empty (unsigned int *typ); +int other_type (unsigned int *typ, int typcd); +static void set_ret (unsigned int *typ); +void set_typ (unsigned int *type, unsigned int bit); +void typcd_bits (int typcd, struct type *typ); +static void typ_deref (unsigned int *src, unsigned int *dest, int chk); +#endif /* OptimizeType */ + +static void abstr_new (struct node *n, struct il_code *il); +static void abstr_typ (struct il_code *il, struct type *typ); +static struct store *alloc_stor (int stor_sz, int n_types); +static void chk_succ (int ret_flag, struct store *susp_stor); +static struct store *cpy_store (struct store *source); +static int eval_cond (struct il_code *il); +static void free_argtyp (struct argtyps *argtyps); +static void free_store (struct store *store); +static void free_wktyp (struct type *typ); +static void find_new (struct node *n); +static struct argtyps *get_argtyp (void); +static struct store *get_store (int clear); +static struct type *get_wktyp (void); +static void infer_act (nodeptr n); +static void infer_con (struct rentry *rec, nodeptr n); +static int infer_il (struct il_code *il); +static void infer_nd (nodeptr n); +static void infer_prc (struct pentry *proc, nodeptr n); +static void mrg_act (struct t_coexpr *coexp, + struct store *e_store, + struct type *rslt_typ); +static void mrg_store (struct store *source, struct store *dest); +static void side_effect (struct il_code *il); +static struct symtyps *symtyps (int nsyms); + +#ifdef TypTrc +static void prt_d_typ (FILE *file, struct typinfo *typ); +static void prt_typ (FILE *file, struct typinfo *typ); +#endif /* TypTrc */ + +#define CanFail 1 + +/* + * cur_coexp is non-null while performing type inference on code from a + * create expression. If it is null, the possible current co-expressions + * must be found from cur_proc. + */ +struct t_coexpr *cur_coexp = NULL; + +struct gentry **proc_map; /* map procedure types to symbol table entries */ +struct rentry **rec_map; /* map record types to record information */ +struct t_coexpr **coexp_map; /* map co-expression types to information */ + +struct typ_info *type_array; + +static int num_new; /* number of types supporting "new" abstract type comp */ + +/* + * Data base component codes are mapped to type inferencing information + * using an array. + */ +struct compnt_info { + int frst_bit; /* first bit in bit vector allocated to component */ + int num_bits; /* number of bits allocated to this component */ + struct store *store; /* maps component "reference" to the type it holds */ + }; +static struct compnt_info *compnt_array; + +static unsigned int frst_fld; /* bit number of 1st record field */ +static unsigned int n_fld; /* number of record fields */ +static unsigned int frst_gbl; /* bit number of 1st global reference type */ +static unsigned int n_gbl; /* number of global variables */ +static unsigned int n_nmgbl; /* number of named global variables */ +static unsigned int frst_loc; /* bit number of 1st local reference type */ +static unsigned int n_loc; /* maximum number of locals in any procedure */ + +static unsigned int nxt_bit; /* next unassigned bit in bit vector */ +unsigned int n_icntyp; /* number of non-variable types */ +unsigned int n_intrtyp; /* number of types in intermediate values */ +static unsigned int n_rttyp; /* number of types in runtime computations */ +unsigned int val_mask; /* mask for non-var types in last int of type */ + +unsigned int null_bit; /* bit for null type */ +unsigned int str_bit; /* bit for string type */ +unsigned int cset_bit; /* bit for cset type */ +unsigned int int_bit; /* bit for integer type */ +unsigned int real_bit; /* bit for real type */ + +static struct store *fld_stor; /* record fields */ + +static int *cur_new; /* allocated types for current operation */ + +static struct store *succ_store = NULL; /* current success store */ +static struct store *fail_store = NULL; /* current failure store */ + +static struct store *dummy_stor; +static struct store *store_pool = NULL; /* free list of store structs */ + +static struct type *type_pool = NULL; /* free list of type structs */ +static struct type cur_rslt = {0, NULL, NULL}; /* result type of operation */ + +static struct argtyps *argtyp_pool = NULL; /* free list of arg type arrays */ +static struct argtyps *arg_typs = NULL; /* current arg type array */ + +static int num_args; /* number of arguments for current operation */ +static int n_vararg; /* size of variable part of arg list to run-time routine */ + +#ifdef OptimizeType +static struct typinfo *any_typ; /* type bit vector with all bits on */ +struct typinfo *free_typinfo = NULL; +struct typinfo *start_typinfo = NULL; +struct typinfo *high_typinfo = NULL; +struct typinfo *low_typinfo = NULL; +#else /* OptimizeType */ +static unsigned int *any_typ; /* type bit vector with all bits on */ +#endif /* OptimizeType */ + +long changed; /* number of changes to type information in this iteration */ +int iteration; /* iteration number for type inferencing */ + +#ifdef TypTrc +static FILE *trcfile = NULL; /* output file pointer for tracing */ +static char *trcname = NULL; /* output file name for tracing */ +static char *trc_indent = ""; +#endif /* TypTrc */ + + +/* + * typeinfer - infer types of operands. If "do_typinfer" is set, actually + * do abstract interpretation, otherwise assume any type for all operands. + */ +void typeinfer() + { + struct gentry *gptr; + struct lentry *lptr; + nodeptr call_main; + struct pentry *p; + struct rentry *rec; + struct t_coexpr *coexp; + struct store *init_store; + struct store *f_store; +#ifdef OptimizeType + struct typinfo *type; +#else /* OptimizeType */ + unsigned int *type; +#endif /* OptimizeType */ + struct implement *ip; + struct lentry **lhash; + struct lentry **vartypmap; + int i, j, k; + int size; + int flag; + +#ifdef TypTrc + /* + * Set up for type tracing. + */ + long start_infer, end_infer; + +#ifdef HighResTime + struct rusage rusage; + + getrusage(RUSAGE_SELF, &rusage); + start_infer = rusage.ru_utime.tv_sec*1000 + rusage.ru_utime.tv_usec/1000; +#else /* HighResTime */ + start_infer = millisec(); +#endif /* HighResTime */ + + typealloc = 1; /* note allocation in this phase */ + + trcname = getenv("TYPTRC"); + + if (trcname != NULL && strlen(trcname) != 0) { + + if (trcname[0] == '|') { + FILE *popen(); + + trcfile = popen(trcname+1, "w"); + } + else + + trcfile = fopen(trcname, "w"); + + if (trcfile == NULL) { + fprintf(stderr, "TYPTRC: cannot open %s\n", trcname); + fflush(stderr); + exit(EXIT_FAILURE); + } + } +#endif /* TypTrc */ + + /* + * Make sure max_prm is large enough for any run-time routine. + */ + for (i = 0; i < IHSize; ++i) + for (ip = bhash[i]; ip != NULL; ip = ip->blink) + if (ip->nargs > max_prm) + max_prm = ip->nargs; + for (i = 0; i < IHSize; ++i) + for (ip = ohash[i]; ip != NULL; ip = ip->blink) + if (ip->nargs > max_prm) + max_prm = ip->nargs; + + /* + * Allocate an arrays to map data base type codes and component codes + * to type inferencing information. + */ + type_array = (struct typ_info *)alloc((unsigned int)(num_typs * + sizeof(struct typ_info))); + compnt_array = (struct compnt_info *)alloc((unsigned int)(num_cmpnts * + sizeof(struct compnt_info))); + + /* + * Find those types that support the "new" abstract type computation + * assign to them locations in the arrays of allocated types associated + * with operation invocations. Also initialize the number of type bits. + * Types with no subtypes have one bit. Types allocated with the the "new" + * abstract have a default sub-type that is allocated here. Procedures + * have a subtype to for string invocable operators. Co-expressions + * have a subtype for &main. Records are handled below. + */ + num_new = 0; + for (i = 0; i < num_typs; ++i) { + if (icontypes[i].support_new) + type_array[i].new_indx = num_new++; + type_array[i].num_bits = 1; /* reserve one type bit */ + } + type_array[list_typ].num_bits = 2; /* default & list for arg to main() */ + + cur_coexp = NewStruct(t_coexpr); + cur_coexp->n = NULL; + cur_coexp->next = NULL; + coexp_lst = cur_coexp; + + if (do_typinfer) { + /* + * Go through the syntax tree for each procedure locating program + * points that may create structures at run time. Allocate the + * appropriate structure type(s) to each such point. + */ + for (p = proc_lst; p != NULL; p = p->next) { + if (p->nargs < 0) + p->arg_lst = type_array[list_typ].num_bits++; /* list for varargs */ + find_new(Tree1(p->tree)); /* initial clause */ + find_new(Tree2(p->tree)); /* body of procedure */ + } + } + + /* + * Allocate a type number for each record type (use record number for + * offset) and a variable type number for each field. + */ + n_fld = 0; + if (rec_lst == NULL) { + type_array[rec_typ].num_bits = 0; + rec_map = NULL; + } + else { + type_array[rec_typ].num_bits = rec_lst->rec_num + 1; + rec_map = (struct rentry **)alloc( + (unsigned int)((rec_lst->rec_num + 1)*sizeof(struct rentry *))); + for (rec = rec_lst; rec != NULL; rec = rec->next) { + rec->frst_fld = n_fld; + n_fld += rec->nfields; + rec_map[rec->rec_num] = rec; + } + } + + /* + * Allocate type numbers to global variables. Don't count those procedure + * variables that are no longer referenced in the syntax tree. Do count + * static variables. Also allocate types to procedures, built-in functions, + * record constructors. + */ + n_gbl = 0; + for (i = 0; i < GHSize; i++) + for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { + flag = gptr->flag; + if (flag & F_SmplInv) + gptr->index = -1; /* unused: set to something not a valid type */ + else { + gptr->index = n_gbl++; + if (flag & (F_Proc | F_Record | F_Builtin)) + gptr->init_type = type_array[proc_typ].num_bits++; + } + if (flag & F_Proc) { + for (lptr = gptr->val.proc->statics; lptr != NULL;lptr = lptr->next) + lptr->val.index = n_gbl++; + } + } + n_nmgbl = n_gbl; + + /* + * Determine relative bit numbers for predefined variable types that + * are treated as sets of global variables. + */ + for (i = 0; i < num_typs; ++i) + if (icontypes[i].deref == DrfGlbl) + type_array[i].frst_bit = n_gbl++; /* converted to absolute later */ + + proc_map = (struct gentry **)alloc( + (unsigned int)((type_array[proc_typ].num_bits)*sizeof(struct gentry *))); + proc_map[0] = NULL; /* proc type for string invocable operators */ + for (i = 0; i < GHSize; i++) + for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { + flag = gptr->flag; + if (!(flag & F_SmplInv) && (flag & (F_Proc | F_Record | F_Builtin))) + proc_map[gptr->init_type] = gptr; + } + + /* + * Allocate type numbers to local variables. The same numbers are reused + * in different procedures. + */ + n_loc = 0; + for (p = proc_lst; p != NULL; p = p->next) { + i = Abs(p->nargs); + for (lptr = p->args; lptr != NULL; lptr = lptr->next) + lptr->val.index = --i; + i = Abs(p->nargs); + for (lptr = p->dynams; lptr != NULL; lptr = lptr->next) + lptr->val.index = i++; + n_loc = Max(n_loc, i); + + /* + * produce a mapping from the variable types used in this procedure + * to the corresponding symbol table entries. + */ + if (n_gbl + n_loc == 0) + vartypmap = NULL; + else + vartypmap = (struct lentry **)alloc( + (unsigned int)((n_gbl + n_loc)*sizeof(struct lentry *))); + for (i = 0; i < n_gbl + n_loc; ++i) + vartypmap[i] = NULL; /* no entries for foreign statics */ + p->vartypmap = vartypmap; + lhash = p->lhash; + for (i = 0; i < LHSize; ++i) { + for (lptr = lhash[i]; lptr != NULL; lptr = lptr->blink) { + switch (lptr->flag) { + case F_Global: + gptr = lptr->val.global; + if (!(gptr->flag & F_SmplInv)) + vartypmap[gptr->index] = lptr; + break; + case F_Static: + vartypmap[lptr->val.index] = lptr; + break; + case F_Dynamic: + case F_Argument: + vartypmap[n_gbl + lptr->val.index] = lptr; + } + } + } + } + + /* + * There is a component reference subtype for every subtype of the + * associated aggregate type. + */ + for (i = 0; i < num_cmpnts; ++i) + compnt_array[i].num_bits = type_array[typecompnt[i].aggregate].num_bits; + + /* + * Assign bits for non-variable (first-class) types. + */ + nxt_bit = 0; + for (i = 0; i < num_typs; ++i) + if (icontypes[i].deref == DrfNone) { + type_array[i].frst_bit = nxt_bit; + nxt_bit += type_array[i].num_bits; + } + + n_icntyp = nxt_bit; /* number of first-class types */ + + /* + * Load some commonly needed bit numbers into global variable. + */ + null_bit = type_array[null_typ].frst_bit; + str_bit = type_array[str_typ].frst_bit; + cset_bit = type_array[cset_typ].frst_bit; + int_bit = type_array[int_typ].frst_bit; + real_bit = type_array[real_typ].frst_bit; + + /* + * Assign bits for predefined variable types that are not treated as + * sets of globals. + */ + for (i = 0; i < num_typs; ++i) + if (icontypes[i].deref == DrfCnst || icontypes[i].deref == DrfSpcl) { + type_array[i].frst_bit = nxt_bit; + nxt_bit += type_array[i].num_bits; + } + + /* + * Assign bits to aggregate compontents that are variables. + */ + for (i = 0; i < num_cmpnts; ++i) + if (typecompnt[i].var) { + compnt_array[i].frst_bit = nxt_bit; + nxt_bit += compnt_array[i].num_bits; + } + + /* + * Assign bits to record fields and named variables. + */ + frst_fld = nxt_bit; + nxt_bit += n_fld; + frst_gbl = nxt_bit; + nxt_bit += n_gbl; + frst_loc = nxt_bit; + nxt_bit += n_loc; + + /* + * Convert from relative to ablsolute bit numbers for predefined variable + * types that are treated as sets of global variables. + */ + for (i = 0; i < num_typs; ++i) + if (icontypes[i].deref == DrfGlbl) + type_array[i].frst_bit += frst_gbl; + + n_intrtyp = nxt_bit; /* number of types for intermediate values */ + + /* + * Assign bits to aggregate compontents that are not variables. These + * are the runtime system's internal descriptor reference types. + */ + for (i = 0; i < num_cmpnts; ++i) + if (!typecompnt[i].var) { + compnt_array[i].frst_bit = nxt_bit; + nxt_bit += compnt_array[i].num_bits; + } + + n_rttyp = nxt_bit; /* total size of type system */ + +#ifdef TypTrc + if (trcfile != NULL) { + /* + * Output a summary of the type system. + */ + for (i = 0; i < num_typs; ++i) { + fprintf(trcfile, "%s", icontypes[i].id); + if (strcmp(icontypes[i].id, icontypes[i].abrv) != 0) + fprintf(trcfile, "(%s)", icontypes[i].abrv); + fprintf(trcfile, " sub-types: %d\n", type_array[i].num_bits); + } + } +#endif /* TypTrc */ + + /* + * The division between bits for first-class types and variables types + * generally occurs in the middle of a word. Set up a mask for extracting + * the first-class types from this word. + */ + val_mask = 0; + i = n_icntyp - (NumInts(n_icntyp) - 1) * IntBits; + while (i--) + val_mask = (val_mask << 1) | 1; + + if (do_typinfer) { + /* + * Create stores large enough for the component references. These + * are global to the entire program, rather than being propagated + * from node to node in the syntax tree. + */ + for (i = 0; i < num_cmpnts; ++i) { + if (i == str_var) + size = n_intrtyp; + else + size = n_icntyp; + compnt_array[i].store = alloc_stor(compnt_array[i].num_bits, size); + } + fld_stor = alloc_stor(n_fld, n_icntyp); + + dummy_stor = get_store(0); + + /* + * First list is arg to main: a list of strings. + */ + set_typ(compnt_array[lst_elem].store->types[1], str_typ); + } + + /* + * Set up a type bit vector with all bits on. + */ +#ifdef OptimizeType + any_typ = alloc_typ(n_rttyp); + any_typ->bits = alloc_mem_typ(DecodeSize(any_typ->packed)); + for (i = 0; i < NumInts(n_rttyp); ++i) + any_typ->bits[i] = ~(unsigned int)0; +#else /* OptimizeType */ + any_typ = alloc_typ(n_rttyp); + for (i = 0; i < NumInts(n_rttyp); ++i) + any_typ[i] = ~(unsigned int)0; +#endif /* OptimizeType */ + + /* + * Initialize stores and return values for procedures. Also initialize + * flag indicating whether the procedure can be executed. + */ + call_main = NULL; + for (p = proc_lst; p != NULL; p = p->next) { + if (do_typinfer) { + p->iteration = 0; + p->ret_typ = alloc_typ(n_intrtyp); + p->coexprs = alloc_typ(n_icntyp); + p->in_store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (p->ret_flag & DoesSusp) + p->susp_store = alloc_stor(n_gbl, n_icntyp); + else + p->susp_store = NULL; + for (i = Abs(p->nargs); i < n_loc; ++i) + set_typ(p->in_store->types[n_gbl + i], null_bit); + if (p->nargs < 0) + set_typ(p->in_store->types[n_gbl + Abs(p->nargs) - 1], + type_array[list_typ].frst_bit + p->arg_lst); + if (strcmp(p->name, "main") == 0) { + /* + * create a the initial call to main with one list argument. + */ + call_main = invk_main(p); + call_main->type = alloc_typ(n_intrtyp); + Tree2(call_main)->type = alloc_typ(n_intrtyp); + set_typ(Tree2(call_main)->type, type_array[list_typ].frst_bit + 1); + call_main->store = alloc_stor(n_gbl + n_loc, n_icntyp); + } + p->out_store = alloc_stor(n_gbl, n_icntyp); + p->reachable = 0; + } + else + p->reachable = 1; + /* + * Analyze the code of the procedure to determine where to place stores + * that survive iterations of type inferencing. Note, both the initial + * clause and the body of the procedure are bounded. + */ + findloops(Tree1(p->tree), 0, NULL); + findloops(Tree2(p->tree), 0, NULL); + } + + /* + * If type inferencing is suppressed, we have set up very conservative + * type information and will do no inferencing. + */ + if (!do_typinfer) + return; + + if (call_main == NULL) + return; /* no main procedure, cannot continue */ + if (tfatals > 0) + return; /* don't do inference if there are fatal errors */ + + /* + * Construct mapping from co-expression types to information + * about the co-expressions and finish initializing the information. + */ + i = type_array[coexp_typ].num_bits; + coexp_map = (struct t_coexpr **)alloc( + (unsigned int)(i * sizeof(struct t_coexpr *))); + for (coexp = coexp_lst; coexp != NULL; coexp = coexp->next) { + coexp_map[--i] = coexp; + coexp->typ_indx = i; + coexp->in_store = alloc_stor(n_gbl + n_loc, n_icntyp); + coexp->out_store = alloc_stor(n_gbl + n_loc, n_icntyp); + coexp->act_typ = alloc_typ(n_intrtyp); + coexp->rslt_typ = alloc_typ(n_intrtyp); + coexp->iteration = 0; + } + + /* + * initialize globals + */ + init_store = get_store(1); + for (i = 0; i < GHSize; i++) + for (gptr = ghash[i]; gptr != NULL; gptr = gptr->blink) { + flag = gptr->flag; + if (!(flag & F_SmplInv)) { + type = init_store->types[gptr->index]; + if (flag & (F_Proc | F_Record | F_Builtin)) + set_typ(type, type_array[proc_typ].frst_bit + gptr->init_type); + else + set_typ(type, null_bit); + } + } + + /* + * Initialize types for predefined variable types. + */ + for (i = 0; i < num_typs; ++i) { + type = NULL; + switch (icontypes[i].deref) { + case DrfGlbl: + /* + * Treated as a global variable. + */ + type = init_store->types[type_array[i].frst_bit - frst_gbl]; + break; + case DrfCnst: + /* + * Type doesn't change so keep one copy. + */ + type = alloc_typ(n_intrtyp); + type_array[i].typ = type; + break; + } + if (type != NULL) { + /* + * Determine which types are in the initial type for this variable. + */ + for (j = 0; j < num_typs; ++j) { + if (icontypes[i].typ[j] != '.') { + for (k = 0; k < type_array[j].num_bits; ++k) + set_typ(type, type_array[j].frst_bit + k); + } + } + } + } + + f_store = get_store(1); + + /* + * Type inferencing iterates over the program until a fixed point is + * reached. + */ + changed = 1L; /* force first iteration */ + iteration = 0; + if (verbose > 1) + fprintf(stderr, "type inferencing: "); + + while (changed > 0L) { + changed = 0L; + ++iteration; + +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "**** iteration %d ****\n", iteration); +#endif /* TypTrc */ + + /* + * Start at the implicit initial call to the main procedure. Inferencing + * walks the call graph from here. + */ + succ_store = cpy_store(init_store); + fail_store = f_store; + infer_nd(call_main); + + /* + * If requested, monitor the progress of inferencing. + */ + switch (verbose) { + case 0: + case 1: + break; + case 2: + fprintf(stderr, "."); + break; + default: /* > 2 */ + if (iteration != 1) + fprintf(stderr, ", "); + fprintf(stderr, "%ld", changed); + } + } + + /* + * Type inferencing is finished, complete any diagnostic output. + */ + if (verbose > 1) + fprintf(stderr, "\n"); + +#ifdef TypTrc + if (trcfile != NULL) { + +#ifdef HighResTime + getrusage(RUSAGE_SELF, &rusage); + end_infer = rusage.ru_utime.tv_sec*1000 + rusage.ru_utime.tv_usec/1000; +#else /* HighResTime */ + end_infer = millisec(); +#endif /* HighResTime */ + fprintf(trcfile, "\n**** inferencing time: %ld milliseconds\n", + end_infer - start_infer); + fprintf(trcfile, "\n**** inferencing space: %ld bytes\n",typespace); + fclose(trcfile); + } + typealloc = 0; +#endif /* TypTrc */ + } + +/* + * find_new - walk the syntax tree allocating structure types where + * operations create new structures. + */ +static void find_new(n) +struct node *n; + { + struct t_coexpr *coexp; + struct node *cases; + struct node *clause; + int nargs; + int i; + + n->new_types = NULL; + switch (n->n_type) { + case N_Cset: + case N_Empty: + case N_Id: + case N_Int: + case N_Next: + case N_Real: + case N_Str: + break; + + case N_Bar: + case N_Break: + case N_Field: + case N_Not: + find_new(Tree0(n)); + break; + + case N_Alt: + case N_Apply: + case N_Limit: + case N_Slist: + find_new(Tree0(n)); + find_new(Tree1(n)); + break; + + case N_Activat: + find_new(Tree1(n)); + find_new(Tree2(n)); + break; + + case N_If: + find_new(Tree0(n)); /* control clause */ + find_new(Tree1(n)); /* then clause */ + find_new(Tree2(n)); /* else clause, may be N_Empty */ + break; + + case N_Create: + /* + * Allocate a sub-type for the co-expressions created here. + */ + n->new_types = (int *)alloc((unsigned int)(sizeof(int))); + n->new_types[0] = type_array[coexp_typ].num_bits++; + coexp = NewStruct(t_coexpr); + coexp->n = Tree0(n); + coexp->next = coexp_lst; + coexp_lst = coexp; + find_new(Tree0(n)); + break; + + case N_Augop: + abstr_new(n, Impl0(n)->in_line); /* assignment */ + abstr_new(n, Impl1(n)->in_line); /* the operation */ + find_new(Tree2(n)); /* 1st operand */ + find_new(Tree3(n)); /* 2nd operand */ + break; + + case N_Case: + find_new(Tree0(n)); /* control clause */ + cases = Tree1(n); + while (cases != NULL) { + if (cases->n_type == N_Ccls) { + clause = cases; + cases = NULL; + } + else { + clause = Tree1(cases); + cases = Tree0(cases); + } + + find_new(Tree0(clause)); /* value of clause */ + find_new(Tree1(clause)); /* body of clause */ + } + if (Tree2(n) != NULL) + find_new(Tree2(n)); /* deflt */ + break; + + case N_Invok: + nargs = Val0(n); /* number of arguments */ + find_new(Tree1(n)); /* thing being invoked */ + for (i = 1; i <= nargs; ++i) + find_new(n->n_field[i+1].n_ptr); /* arg i */ + break; + + case N_InvOp: + /* + * This is a call to an operation, this is what we must + * check for "new" abstract type computation. + */ + nargs = Val0(n); /* number of arguments */ + abstr_new(n, Impl1(n)->in_line); /* operation */ + for (i = 1; i <= nargs; ++i) + find_new(n->n_field[i+1].n_ptr); /* arg i */ + break; + + case N_InvProc: + case N_InvRec: + nargs = Val0(n); /* number of arguments */ + for (i = 1; i <= nargs; ++i) + find_new(n->n_field[i+1].n_ptr); /* arg i */ + break; + + case N_Loop: + switch ((int)Val0(Tree0(n))) { + case EVERY: + case SUSPEND: + case WHILE: + case UNTIL: + find_new(Tree1(n)); /* control clause */ + find_new(Tree2(n)); /* do clause - may be N_Empty*/ + break; + + case REPEAT: + find_new(Tree1(n)); /* clause */ + break; + } + + case N_Ret: + if (Val0(Tree0(n)) == RETURN) + find_new(Tree1(n)); /* value - may be N_Empty */ + break; + + case N_Scan: + if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) + abstr_new(n, optab[asgn_loc].binary->in_line); + find_new(Tree1(n)); /* subject */ + find_new(Tree2(n)); /* body */ + break; + + case N_Sect: + abstr_new(n, Impl0(n)->in_line); /* sectioning */ + if (Impl1(n) != NULL) + abstr_new(n, Impl1(n)->in_line); /* plus, minus, or nothing */ + find_new(Tree2(n)); /* 1st operand */ + find_new(Tree3(n)); /* 2nd operand */ + find_new(Tree4(n)); /* 3rd operand */ + break; + + case N_SmplAsgn: + case N_SmplAug: + find_new(Tree3(n)); + break; + + default: + fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); + exit(EXIT_FAILURE); + } + } + +/* + * abstr_new - find the abstract clauses in the implementation of an operation. + * If they indicate that the operations creates structures, allocate a + * type for the structures and associate it with the node in the syntax tree. + */ +static void abstr_new(n, il) +struct node *n; +struct il_code *il; + { + int i; + int num_cases, indx; + struct typ_info *t_info; + + if (il == NULL) + return; + + switch (il->il_type) { + case IL_New: + /* + * We have found a "new" construct in an abstract type computation. + * Make sure an array has been created to hold the types allocated + * to this call, then allocate the indicated type if one has not + * already been allocated. + */ + if (n->new_types == NULL) { + n->new_types = (int *)alloc((unsigned int)(num_new * sizeof(int))); + for (i = 0; i < num_new; ++i) + n->new_types[i] = -1; + } + t_info = &type_array[il->u[0].n]; /* index by type code */ + if (n->new_types[t_info->new_indx] < 0) { + n->new_types[t_info->new_indx] = t_info->num_bits++; +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) %s\n", n->n_file, n->n_line, + n->n_col, icontypes[il->u[0].n].id); +#endif /* TypTrc */ + } + i = il->u[1].n; /* num args */ + indx = 2; + while (i--) + abstr_new(n, il->u[indx++].fld); + break; + + case IL_If1: + abstr_new(n, il->u[1].fld); + break; + + case IL_If2: + abstr_new(n, il->u[1].fld); + abstr_new(n, il->u[2].fld); + break; + + case IL_Tcase1: + num_cases = il->u[1].n; + indx = 2; + for (i = 0; i < num_cases; ++i) { + indx += 2; /* skip type info */ + abstr_new(n, il->u[indx++].fld); /* action */ + } + break; + + case IL_Tcase2: + num_cases = il->u[1].n; + indx = 2; + for (i = 0; i < num_cases; ++i) { + indx += 2; /* skip type info */ + abstr_new(n, il->u[indx++].fld); /* action */ + } + abstr_new(n, il->u[indx].fld); /* default */ + break; + + case IL_Lcase: + num_cases = il->u[0].n; + indx = 1; + for (i = 0; i < num_cases; ++i) { + ++indx; /* skip selection num */ + abstr_new(n, il->u[indx++].fld); /* action */ + } + abstr_new(n, il->u[indx].fld); /* default */ + break; + + case IL_Acase: + abstr_new(n, il->u[2].fld); /* C_integer action */ + if (largeints) + abstr_new(n, il->u[3].fld); /* integer action */ + abstr_new(n, il->u[4].fld); /* C_double action */ + break; + + case IL_Abstr: + case IL_Inter: + case IL_Lst: + case IL_TpAsgn: + case IL_Union: + abstr_new(n, il->u[0].fld); + abstr_new(n, il->u[1].fld); + break; + + case IL_Compnt: + case IL_Store: + case IL_VarTyp: + abstr_new(n, il->u[0].fld); + break; + + case IL_Block: + case IL_Call: + case IL_Const: /* should have been replaced by literal node */ + case IL_Err1: + case IL_Err2: + case IL_IcnTyp: + case IL_Subscr: + case IL_Var: + break; + + default: + fprintf(stderr, "compiler error: unknown info in data base\n"); + exit(EXIT_FAILURE); + } + } + +/* + * alloc_stor - allocate a store with empty types. + */ +static struct store *alloc_stor(stor_sz, n_types) +int stor_sz; +int n_types; + { + struct store *stor; + int i; + + /* + * If type inferencing is disabled, we don't actually make use of + * any stores, but the initialization code asks for them anyway. + */ + if (!do_typinfer) + return NULL; + +#ifdef OptimizeType + stor = (struct store *)alloc((unsigned int)(sizeof(struct store) + + ((stor_sz - 1) * sizeof(struct typinfo *)))); + stor->next = NULL; + stor->perm = 1; + for (i = 0; i < stor_sz; ++i) { + stor->types[i] = (struct typinfo *)alloc_typ(n_types); + } +#else /* OptimizeType */ + stor = (struct store *)alloc((unsigned int)(sizeof(struct store) + + ((stor_sz - 1) * sizeof(unsigned int *)))); + stor->next = NULL; + stor->perm = 1; + for (i = 0; i < stor_sz; ++i) { + stor->types[i] = (unsigned int *)alloc_typ(n_types); + } +#endif /* OptimizeType */ + + return stor; + } + +/* + * findloops - find both explicit loops and implicit loops caused by + * goal-directed evaluation. Allocate stores for them. Determine which + * expressions cannot fail (used to eliminate dynamic store allocation + * for some bounded expressions). Allocate stores for 'if' and 'case' + * expressions that can be resumed. Initialize expression types. + * The syntax tree is walked in reverse execution order looking for + * failure and for generators. + */ +static int findloops(n, resume, rslt_type) +struct node *n; +int resume; +#ifdef OptimizeType +struct typinfo *rslt_type; +#else /* OptimizeType */ +unsigned int *rslt_type; +#endif /* OptimizeType */ + { + struct loop { + int resume; + int can_fail; + int every_cntrl; +#ifdef OptimizeType + struct typinfo *type; +#else /* OptimizeType */ + unsigned int *type; +#endif /* OptimizeType */ + struct loop *prev; + } loop_info; + struct loop *loop_sav; + static struct loop *cur_loop = NULL; + struct node *cases; + struct node *clause; + int can_fail; + int nargs, i; + + n->store = NULL; + if (!do_typinfer) + rslt_type = any_typ; + + switch (n->n_type) { + case N_Activat: + if (rslt_type == NULL) + rslt_type = alloc_typ(n_intrtyp); + n->type = rslt_type; + /* + * Assume activation can fail. + */ + can_fail = findloops(Tree2(n), 1, NULL); + can_fail = findloops(Tree1(n), can_fail, NULL); + n->symtyps = symtyps(2); + if (optab[Val0(Tree0(n))].tok.t_type == AUGAT) + n->symtyps->next = symtyps(2); + break; + + case N_Alt: + if (rslt_type == NULL) + rslt_type = alloc_typ(n_intrtyp); + n->type = rslt_type; + +#ifdef TypTrc + rslt_type = NULL; /* don't share result loc with subexpressions*/ +#endif /* TypTrc */ + + if (resume) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + can_fail = findloops(Tree0(n), resume, rslt_type) | + findloops(Tree1(n), resume, rslt_type); + break; + + case N_Apply: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + /* + * Assume operation can suspend or fail. + */ + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + can_fail = findloops(Tree1(n), 1, NULL); + can_fail = findloops(Tree0(n), can_fail, NULL); + n->symtyps = symtyps(max_sym); + break; + + case N_Augop: + if (rslt_type == NULL) + rslt_type = alloc_typ(n_intrtyp); + n->type = rslt_type; + + can_fail = resume; + /* + * Impl0(n) is assignment. + */ + if (resume && Impl0(n)->ret_flag & DoesSusp) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(Impl0(n)->ret_flag)) + can_fail = 1; + /* + * Impl1(n) is the augmented operation. + */ + if (can_fail && Impl1(n)->ret_flag & DoesSusp && n->store == NULL) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(Impl1(n)->ret_flag)) + can_fail = 1; + can_fail = findloops(Tree3(n), can_fail, NULL); /* operand 2 */ + can_fail = findloops(Tree2(n), can_fail, NULL); /* operand 1 */ + n->type = Tree2(n)->type; + Typ4(n) = alloc_typ(n_intrtyp); + n->symtyps = symtyps(n_arg_sym(Impl1(n))); + n->symtyps->next = symtyps(n_arg_sym(Impl0(n))); + break; + + case N_Bar: + can_fail = findloops(Tree0(n), resume, rslt_type); + n->type = Tree0(n)->type; + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + break; + + case N_Break: + if (cur_loop == NULL) { + nfatal(n, "invalid context for break", NULL); + return 0; + } + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + loop_sav = cur_loop; + cur_loop = cur_loop->prev; + loop_sav->can_fail |= findloops(Tree0(n), loop_sav->resume, + loop_sav->type); + cur_loop = loop_sav; + can_fail = 0; + break; + + case N_Case: + if (rslt_type == NULL) + rslt_type = alloc_typ(n_intrtyp); + n->type = rslt_type; + +#ifdef TypTrc + rslt_type = NULL; /* don't share result loc with subexpressions*/ +#endif /* TypTrc */ + + if (resume) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + + /* + * control clause is bounded + */ + can_fail = findloops(Tree0(n), 0, NULL); + + cases = Tree1(n); + while (cases != NULL) { + if (cases->n_type == N_Ccls) { + clause = cases; + cases = NULL; + } + else { + clause = Tree1(cases); + cases = Tree0(cases); + } + + /* + * The expression being compared can be resumed. + */ + findloops(Tree0(clause), 1, NULL); + + /* + * Body. + */ + can_fail |= findloops(Tree1(clause), resume, rslt_type); + } + + if (Tree2(n) == NULL) + can_fail = 1; + else + can_fail |= findloops(Tree2(n), resume, rslt_type); /* default */ + break; + + case N_Create: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + findloops(Tree0(n), 1, NULL); /* co-expression code */ + /* + * precompute type + */ + i= type_array[coexp_typ].frst_bit; + if (do_typinfer) + i += n->new_types[0]; + set_typ(n->type, i); + can_fail = resume; + break; + + case N_Cset: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + set_typ(n->type, type_array[cset_typ].frst_bit); /* precompute type */ + can_fail = resume; + break; + + case N_Empty: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + set_typ(n->type, null_bit); /* precompute type */ + can_fail = resume; + break; + + case N_Id: { + struct lentry *var; + + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + /* + * Precompute type + */ + var = LSym0(n); + if (var->flag & F_Global) + set_typ(n->type, frst_gbl + var->val.global->index); + else if (var->flag & F_Static) + set_typ(n->type, frst_gbl + var->val.index); + else + set_typ(n->type, frst_loc + var->val.index); + can_fail = resume; + } + break; + + case N_Field: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + can_fail = findloops(Tree0(n), resume, NULL); + n->symtyps = symtyps(1); + break; + + case N_If: + if (rslt_type == NULL) + rslt_type = alloc_typ(n_intrtyp); + n->type = rslt_type; + +#ifdef TypTrc + rslt_type = NULL; /* don't share result loc with subexpressions*/ +#endif /* TypTrc */ + /* + * control clause is bounded + */ + findloops(Tree0(n), 0, NULL); + can_fail = findloops(Tree1(n), resume, rslt_type); + if (Tree2(n)->n_type == N_Empty) + can_fail = 1; + else { + if (resume) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + can_fail |= findloops(Tree2(n), resume, rslt_type); + } + break; + + case N_Int: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + set_typ(n->type, int_bit); /* precompute type */ + can_fail = resume; + break; + + case N_Invok: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + nargs = Val0(n); /* number of arguments */ + /* + * Assume operation can suspend and fail. + */ + if (resume) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + can_fail = 1; + for (i = nargs; i >= 0; --i) + can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); + n->symtyps = symtyps(max_sym); + break; + + case N_InvOp: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + nargs = Val0(n); /* number of arguments */ + if (resume && Impl1(n)->ret_flag & DoesSusp) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(Impl1(n)->ret_flag)) + can_fail = 1; + else + can_fail = resume; + for (i = nargs; i >= 1; --i) + can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); + n->symtyps = symtyps(n_arg_sym(Impl1(n))); + break; + + case N_InvProc: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + nargs = Val0(n); /* number of arguments */ + if (resume && Proc1(n)->ret_flag & DoesSusp) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (Proc1(n)->ret_flag & DoesFail) + can_fail = 1; + else + can_fail = resume; + for (i = nargs; i >= 1; --i) + can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); + break; + + case N_InvRec: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + nargs = Val0(n); /* number of args */ + if (err_conv) + can_fail = 1; + else + can_fail = resume; + for (i = nargs; i >= 1; --i) + can_fail = findloops(n->n_field[i+1].n_ptr, can_fail, NULL); + break; + + case N_Limit: + findloops(Tree0(n), resume, rslt_type); + can_fail = findloops(Tree1(n), 1, NULL); + n->type = Tree0(n)->type; + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + n->symtyps = symtyps(1); + break; + + case N_Loop: { + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + loop_info.prev = cur_loop; + loop_info.resume = resume; + loop_info.can_fail = 0; + loop_info.every_cntrl = 0; + loop_info.type = n->type; + cur_loop = &loop_info; + switch ((int)Val0(Tree0(n))) { + case EVERY: + case SUSPEND: + /* + * The control clause can be resumed. The body is bounded. + */ + loop_info.every_cntrl = 1; + can_fail = findloops(Tree1(n), 1, NULL); + loop_info.every_cntrl = 0; + findloops(Tree2(n), 0, NULL); + break; + + case REPEAT: + /* + * The loop needs a saved store. The body is bounded. + */ + findloops(Tree1(n), 0, NULL); + can_fail = 0; + break; + + case WHILE: + /* + * The loop needs a saved store. The control + * clause and the body are each bounded. + */ + can_fail = findloops(Tree1(n), 0, NULL); + findloops(Tree2(n), 0, NULL); + break; + + case UNTIL: + /* + * The loop needs a saved store. The control + * clause and the body are each bounded. + */ + findloops(Tree1(n), 0, NULL); + findloops(Tree2(n), 0, NULL); + can_fail = 1; + break; + } + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (do_typinfer && resume) + n->store->next = alloc_stor(n_gbl + n_loc, n_icntyp); + can_fail |= cur_loop->can_fail; + cur_loop = cur_loop->prev; + } + break; + + case N_Next: + if (cur_loop == NULL) { + nfatal(n, "invalid context for next", NULL); + return 1; + } + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + can_fail = cur_loop->every_cntrl; + break; + + case N_Not: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + set_typ(n->type, null_bit); /* precompute type */ + /* + * The expression is bounded. + */ + findloops(Tree0(n), 0, NULL); + can_fail = 1; + break; + + case N_Real: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + set_typ(n->type, real_bit); /* precompute type */ + can_fail = resume; + break; + + case N_Ret: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + if (Val0(Tree0(n)) == RETURN) { + /* + * The expression is bounded. + */ + findloops(Tree1(n), 0, NULL); + } + can_fail = 0; + break; + + case N_Scan: { + struct implement *asgn_impl; + + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + n->symtyps = symtyps(1); + can_fail = resume; + if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) { + asgn_impl = optab[asgn_loc].binary; + if (resume && asgn_impl->ret_flag & DoesSusp) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(asgn_impl->ret_flag)) + can_fail = 1; + n->symtyps->next = symtyps(n_arg_sym(asgn_impl)); + } + can_fail = findloops(Tree2(n), can_fail, NULL); /* body */ + can_fail = findloops(Tree1(n), can_fail, NULL); /* subject */ + } + break; + + case N_Sect: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + can_fail = resume; + /* + * Impl0(n) is sectioning. + */ + if (resume && Impl0(n)->ret_flag & DoesSusp) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(Impl0(n)->ret_flag)) + can_fail = 1; + n->symtyps = symtyps(n_arg_sym(Impl0(n))); + if (Impl1(n) != NULL) { + /* + * Impl1(n) is plus or minus + */ + if (can_fail && Impl1(n)->ret_flag & DoesSusp && n->store == NULL) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(Impl1(n)->ret_flag)) + can_fail = 1; + n->symtyps->next = symtyps(n_arg_sym(Impl1(n))); + } + can_fail = findloops(Tree4(n), can_fail, NULL); /* operand 3 */ + can_fail = findloops(Tree3(n), can_fail, NULL); /* operand 2 */ + can_fail = findloops(Tree2(n), can_fail, NULL); /* operand 1 */ + break; + + case N_Slist: + /* + * 1st expression is bounded. + */ + findloops(Tree0(n), 0, NULL); + can_fail = findloops(Tree1(n), resume, rslt_type); + n->type = Tree1(n)->type; + break; + + case N_SmplAsgn: + can_fail = findloops(Tree3(n), resume, NULL); /* 2nd operand */ + findloops(Tree2(n), can_fail, rslt_type); /* variable */ + n->type = Tree2(n)->type; + break; + + case N_SmplAug: + can_fail = resume; + /* + * Impl1(n) is the augmented operation. + */ + if (resume && Impl1(n)->ret_flag & DoesSusp) + n->store = alloc_stor(n_gbl + n_loc, n_icntyp); + if (MightFail(Impl1(n)->ret_flag)) + can_fail = 1; + can_fail = findloops(Tree3(n), can_fail, NULL); /* 2nd operand */ + findloops(Tree2(n), can_fail, rslt_type); /* variable */ + n->symtyps = symtyps(n_arg_sym(Impl1(n))); + n->type = Tree2(n)->type; + Typ4(n) = alloc_typ(n_intrtyp); + break; + + case N_Str: + if (rslt_type == NULL) + n->type = alloc_typ(n_intrtyp); + else + n->type = rslt_type; + set_typ(n->type, str_bit); /* precompute type */ + can_fail = resume; + break; + + default: + fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); + exit(EXIT_FAILURE); + } + if (can_fail) + n->flag = CanFail; + else + n->flag = 0; + return can_fail; + } + +/* + * symtyps - determine the number of entries needed for a symbol table + * that maps argument indexes to types for an operation in the + * data base. Allocate the symbol table. + */ +static struct symtyps *symtyps(nsyms) +int nsyms; + { + struct symtyps *tab; + + if (nsyms == 0) + return NULL; + +#ifdef OptimizeType + tab = (struct symtyps *)alloc((unsigned int)(sizeof(struct symtyps) + + (nsyms - 1) * sizeof(struct typinfo *))); +#else /* OptimizeType */ + tab = (struct symtyps *)alloc((unsigned int)(sizeof(struct symtyps) + + (nsyms - 1) * sizeof(int *))); +#endif /* OptimizeType */ + tab->nsyms = nsyms; + tab->next = NULL; + while (nsyms) + tab->types[--nsyms] = alloc_typ(n_intrtyp); + return tab; + } + +/* + * infer_proc - perform type inference on a call to an Icon procedure. + */ +static void infer_prc(proc, n) +struct pentry *proc; +nodeptr n; + { + struct store *s_store; + struct store *f_store; + struct store *store; + struct pentry *sv_proc; + struct t_coexpr *sv_coexp; + struct lentry *lptr; + nodeptr n1; + int i; + int nparams; + int coexp_bit; + + /* + * Determine what co-expressions the procedure might be called from. + */ + if (cur_coexp == NULL) + ChkMrgTyp(n_icntyp, cur_proc->coexprs, proc->coexprs) + else { + coexp_bit = type_array[coexp_typ].frst_bit + cur_coexp->typ_indx; + if (!bitset(proc->coexprs, coexp_bit)) { + ++changed; + set_typ(proc->coexprs, coexp_bit); + } + } + + proc->reachable = 1; /* this procedure can be called */ + + /* + * If this procedure can suspend, there may be backtracking paths + * to this invocation. If so, propagate types of globals from the + * backtracking paths to the suspends of the procedure and propagate + * types of locals to the success store of the call. + */ + if (proc->ret_flag & DoesSusp && n->store != NULL) { + for (i = 0; i < n_gbl; ++i) + ChkMrgTyp(n_icntyp, n->store->types[i], proc->susp_store->types[i]) + for (i = 0; i < n_loc; ++i) + MrgTyp(n_icntyp, n->store->types[n_gbl + i], succ_store->types[n_gbl + + i]) + } + + /* + * Merge the types of global variables into the "in store" of the + * procedure. Because the body of the procedure may already have + * been processed for this pass, the "changed" flag must be set if + * there is a change of type in the store. This will insure that + * there will be another iteration in which to propagate the change + * into the body. + */ + store = proc->in_store; + for (i = 0; i < n_gbl; ++i) + ChkMrgTyp(n_icntyp, succ_store->types[i], store->types[i]) + +#ifdef TypTrc + /* + * Trace the call. + */ + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) %s%s(", n->n_file, n->n_line, n->n_col, + trc_indent, proc->name); +#endif /* TypTrc */ + + /* + * Get the types of the arguments, starting with the non-varargs part. + */ + nparams = proc->nargs; /* number of parameters */ + if (nparams < 0) + nparams = -nparams - 1; + for (i = 0; i < num_args && i < nparams; ++i) { + typ_deref(arg_typs->types[i], store->types[n_gbl + i], 1); + +#ifdef TypTrc + if (trcfile != NULL) { + /* + * Trace the argument type to the call. + */ + if (i > 0) + fprintf(trcfile, ", "); + prt_d_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + } + + /* + * Get the type of the varargs part of the argument list. + */ + if (proc->nargs < 0) + while (i < num_args) { + typ_deref(arg_typs->types[i], + compnt_array[lst_elem].store->types[proc->arg_lst], 1); + +#ifdef TypTrc + if (trcfile != NULL) { + /* + * Trace the argument type to the call. + */ + if (i > 0) + fprintf(trcfile, ", "); + prt_d_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + ++i; + } + + /* + * Missing arguments have the null type. + */ + while (i < nparams) { + set_typ(store->types[n_gbl + i], null_bit); + ++i; + } + +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, ")\n"); + { + char *trc_ind_sav = trc_indent; + trc_indent = ""; /* staring a new procedure, don't indent tracing */ +#endif /* TypTrc */ + + /* + * only perform type inference on the body of a procedure + * once per iteration + */ + if (proc->iteration < iteration) { + proc->iteration = iteration; + s_store = succ_store; + f_store = fail_store; + sv_proc = cur_proc; + succ_store = cpy_store(proc->in_store); + cur_proc = proc; + sv_coexp = cur_coexp; + cur_coexp = NULL; /* we are not in a create expression */ + /* + * Perform type inference on the initial clause. Static variables + * are initialized to null on this path. + */ + for (lptr = proc->statics; lptr != NULL; lptr = lptr->next) + set_typ(succ_store->types[lptr->val.index], null_bit); + n1 = Tree1(proc->tree); + if (n1->flag & CanFail) { + /* + * The initial clause can fail. Because it is bounded, we need + * a new failure store that we can merge into the success store + * at the end of the clause. + */ + store = get_store(1); + fail_store = store; + infer_nd(n1); + mrg_store(store, succ_store); + free_store(store); + } + else + infer_nd(n1); + /* + * Perform type inference on the body of procedure. Execution may + * pass directly to it without executing initial clause. + */ + mrg_store(proc->in_store, succ_store); + n1 = Tree2(proc->tree); + if (n1->flag & CanFail) { + /* + * The body can fail. Because it is bounded, we need a new failure + * store that we can merge into the success store at the end of + * the procedure. + */ + store = get_store(1); + fail_store = store; + infer_nd(n1); + mrg_store(store, succ_store); + free_store(store); + } + else + infer_nd(n1); + set_ret(NULL); /* implicit fail */ + free_store(succ_store); + succ_store = s_store; + fail_store = f_store; + cur_proc = sv_proc; + cur_coexp = sv_coexp; + } + +#ifdef TypTrc + trc_indent = trc_ind_sav; + } +#endif /* TypTrc */ + + /* + * Get updated types for global variables at the end of the call. + */ + store = proc->out_store; + for (i = 0; i < n_gbl; ++i) + CpyTyp(n_icntyp, store->types[i], succ_store->types[i]); + + /* + * If the procedure can fail, merge variable types into the failure + * store. + */ + if (proc->ret_flag & DoesFail) + mrg_store(succ_store, fail_store); + + /* + * The return type of the procedure is the result type of the call. + */ + MrgTyp(n_intrtyp, proc->ret_typ, n->type); + } + +/* + * cpy_store - make a copy of a store. + */ +static struct store *cpy_store(source) +struct store *source; + { + struct store *dest; + int stor_sz; + int i; + + if (source == NULL) + dest = get_store(1); + else { + stor_sz = n_gbl + n_loc; + dest = get_store(0); + for (i = 0; i < stor_sz; ++i) + CpyTyp(n_icntyp, source->types[i], dest->types[i]) + } + return dest; + } + +/* + * mrg_store - merge the source store into the destination store. + */ +static void mrg_store(source, dest) +struct store *source; +struct store *dest; + { + int i; + + if (source == NULL) + return; + + /* + * Is this store included in the state that must be checked for a fixed + * point? + */ + if (dest->perm) { + for (i = 0; i < n_gbl + n_loc; ++i) + ChkMrgTyp(n_icntyp, source->types[i], dest->types[i]) + } + else { + for (i = 0; i < n_gbl + n_loc; ++i) + MrgTyp(n_icntyp, source->types[i], dest->types[i]) + } + } + +/* + * set_ret - Save return type and the store for global variables. + */ +static void set_ret(typ) +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ + { + int i; + + /* + * Merge the return type into the type of the procedure, dereferencing + * locals in the process. + */ + if (typ != NULL) + deref_lcl(typ, cur_proc->ret_typ); + + /* + * Update the types that variables may have upon exit of the procedure. + */ + for (i = 0; i < n_gbl; ++i) + MrgTyp(n_icntyp, succ_store->types[i], cur_proc->out_store->types[i]); + } + +/* + * deref_lcl - dereference local variable sub-types. + */ +static void deref_lcl(src, dest) +#ifdef OptimizeType +struct typinfo *src; +struct typinfo *dest; +#else /* OptimizeType */ +unsigned int *src; +unsigned int *dest; +#endif /* OptimizeType */ + { + int i, j; + int ref_gbl; + int frst_stv; + int num_stv; + struct store *stv_stor; + struct type *wktyp; + + /* + * Make a copy of the type to be dereferenced. + */ + wktyp = get_wktyp(); + CpyTyp(n_intrtyp, src, wktyp->bits); + + /* + * Determine which variable types must be dereferenced. Merge the + * dereferenced type into the return type and delete the variable + * type. Start with simple local variables. + */ + for (i = 0; i < n_loc; ++i) + if (bitset(wktyp->bits, frst_loc + i)) { + MrgTyp(n_icntyp, succ_store->types[n_gbl + i], wktyp->bits) + clr_typ(wktyp->bits, frst_loc + i); + } + + /* + * Check for substring trapped variables. If a sub-string trapped + * variable references a local, add "string" to the return type. + * If a sub-string trapped variable references a global, leave the + * trapped variable in the return type. + * It is theoretically possible for a sub-string trapped variable type to + * reference both a local and a global. When the trapped variable type + * is returned to the calling procedure, the local is re-interpreted + * as a local of that procedure. This is a "valid" overestimate of + * of the semantics of the return. Because this is unlikely to occur + * in real programs, the overestimate is of no practical consequence. + */ + num_stv = type_array[stv_typ].num_bits; + frst_stv = type_array[stv_typ].frst_bit; + stv_stor = compnt_array[str_var].store; + for (i = 0; i < num_stv; ++i) { + if (bitset(wktyp->bits, frst_stv + i)) { + /* + * We have found substring trapped variable i, see whether it + * references locals or globals. Globals include structure + * element references. + */ + for (j = 0; j < n_loc; ++j) + if (bitset(stv_stor->types[i], frst_loc + j)) { + set_typ(wktyp->bits, str_bit); + break; + } + ref_gbl = 0; + for (j = n_icntyp; j < frst_loc; ++j) + if (bitset(stv_stor->types[i], j)) { + ref_gbl = 1; + break; + } + /* + * Keep the trapped variable only if it references globals. + */ + if (!ref_gbl) + clr_typ(wktyp->bits, frst_stv + i); + } + } + + /* + * Merge the types into the destination. + */ + MrgTyp(n_intrtyp, wktyp->bits, dest); + +#ifdef TypTrc + if (trcfile != NULL) { + prt_typ(trcfile, wktyp->bits); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + + free_wktyp(wktyp); + } + +/* + * get_store - get a store large enough to hold globals and locals. + */ +static struct store *get_store(clear) +int clear; + { + struct store *store; + int store_sz; + int i; + + /* + * Warning, stores for all procedures must be the same size. In some + * situations involving sub-string trapped variables (for example + * when using the "default" trapped variable) a referenced local variable + * type may be interpreted in a procedure to which it does not belong. + * This represents an impossible execution and type inference may + * "legally" produce any results for this part of the abstract + * interpretation. As long as the store is large enough to include any + * such "impossible" variables, type inference will do something legal. + * Note that n_loc is the maximum number of locals in any procedure, + * so store_sz is large enough. + */ + store_sz = n_gbl + n_loc; + if ((store = store_pool) == NULL) { + store = alloc_stor(store_sz, n_icntyp); + store->perm = 0; + } + else { + store_pool = store_pool->next; + /* + * See if the variables in the store should be initialized to the + * empty type. + */ + if (clear) + for (i = 0; i < store_sz; ++i) + ClrTyp(n_icntyp, store->types[i]); + } + return store; + } + +static void free_store(store) +struct store *store; + { + store->next = store_pool; + store_pool = store; + } + +/* + * infer_nd - perform type inference on a subtree of the syntax tree. + */ +static void infer_nd(n) +nodeptr n; + { + struct node *cases; + struct node *clause; + struct store *s_store; + struct store *f_store; + struct store *store; + struct loop { + struct store *succ_store; + struct store *fail_store; + struct store *next_store; + struct store *susp_store; + struct loop *prev; + } loop_info; + struct loop *loop_sav; + static struct loop *cur_loop; + struct argtyps *sav_argtyp; + int sav_nargs; + struct type *wktyp; + int i; + + switch (n->n_type) { + case N_Activat: + infer_act(n); + break; + + case N_Alt: + f_store = fail_store; + store = get_store(1); + fail_store = store; + infer_nd(Tree0(n)); /* 1st alternative */ + + /* + * "Correct" type inferencing of alternation has a performance + * problem. Propagating stores through nested alternation + * requires as many iterations as the depth of the nesting. + * This is solved by adding two edges to the flow graph. These + * represent impossible execution paths but this does not + * affect the soundness of type inferencing and, in "real" + * programs, does not affect the preciseness of its inference. + * One edge is directly from the 1st alternative to the 2nd. + * The other is a backtracking edge immediately back into + * the alternation from the 1st alternative. + */ + mrg_store(succ_store, store); /* imaginary edge to 2nd alternative */ + + if (n->store != NULL) { + mrg_store(succ_store, n->store); /* imaginary backtracking edge */ + mrg_store(n->store, fail_store); + } + s_store = succ_store; + succ_store = store; + fail_store = f_store; + infer_nd(Tree1(n)); /* 2nd alternative */ + mrg_store(s_store, succ_store); + free_store(s_store); + if (n->store != NULL) + mrg_store(n->store, fail_store); + fail_store = n->store; +#ifdef TypTrc + MrgTyp(n_intrtyp, Tree0(n)->type, n->type); + MrgTyp(n_intrtyp, Tree1(n)->type, n->type); +#else /* TypTrc */ + /* + * Type is computed by sub-expressions directly into n->type. + */ +#endif /* TypTrc */ + break; + + case N_Apply: { + struct type *lst_types; + int frst_lst; + int num_lst; + struct store *lstel_stor; + + infer_nd(Tree0(n)); /* thing being invoked */ + infer_nd(Tree1(n)); /* list */ + + frst_lst = type_array[list_typ].frst_bit; + num_lst = type_array[list_typ].num_bits; + lstel_stor = compnt_array[lst_elem].store; + + /* + * All that is available is a "summary" of the types of the + * elements of the list. Each argument to the invocation + * could be any type in the summary. Set up a maximum length + * argument list. + */ + lst_types = get_wktyp(); + typ_deref(Tree1(n)->type, lst_types->bits, 0); + wktyp = get_wktyp(); + for (i = 0; i < num_lst; ++i) + if (bitset(lst_types->bits, frst_lst + i)) + MrgTyp(n_icntyp, lstel_stor->types[i], wktyp->bits); + bitset(wktyp->bits, null_bit); /* arg list extension might be done */ + + sav_nargs = num_args; + sav_argtyp = arg_typs; + num_args = max_prm; + arg_typs = get_argtyp(); + for (i = 0; i < max_prm; ++i) + arg_typs->types[i] = wktyp->bits; + gen_inv(Tree0(n)->type, n); /* inference on general invocation */ + + free_wktyp(wktyp); + free_wktyp(lst_types); + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + } + break; + + case N_Augop: + infer_nd(Tree2(n)); /* 1st operand */ + infer_nd(Tree3(n)); /* 2nd operand */ + /* + * Perform type inference on the operation. + */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = 2; + arg_typs->types[0] = Tree2(n)->type; + arg_typs->types[1] = Tree3(n)->type; + infer_impl(Impl1(n), n, n->symtyps, Typ4(n)); + chk_succ(Impl1(n)->ret_flag, n->store); + /* + * Perform type inference on the assignment. + */ + arg_typs->types[1] = Typ4(n); + infer_impl(Impl0(n), n, n->symtyps->next, n->type); + chk_succ(Impl0(n)->ret_flag, n->store); + + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + break; + + case N_Bar: + /* + * This operation intercepts failure and has an associated + * resumption store. If backtracking reaches this operation + * execution may either continue backward or proceed forward + * again. + */ + mrg_store(n->store, fail_store); + mrg_store(n->store, succ_store); + fail_store = n->store; + infer_nd(Tree0(n)); + /* + * Type is computed by operand. + */ + break; + + case N_Break: + /* + * The success and failure stores for the operand of break are + * those associated with the enclosing loop. + */ + fail_store = cur_loop->fail_store; + loop_sav = cur_loop; + cur_loop = cur_loop->prev; + infer_nd(Tree0(n)); + cur_loop = loop_sav; + mrg_store(succ_store, cur_loop->succ_store); + if (cur_loop->susp_store != NULL) + mrg_store(cur_loop->susp_store, fail_store); + free_store(succ_store); + succ_store = get_store(1); /* empty store says: can't get past here */ + fail_store = dummy_stor; /* shouldn't be used */ + /* + * Result of break is empty type. Result type of expression + * is computed directly into result type of loop. + */ + break; + + case N_Case: + f_store = fail_store; + s_store = get_store(1); + infer_nd(Tree0(n)); /* control clause */ + cases = Tree1(n); + while (cases != NULL) { + if (cases->n_type == N_Ccls) { + clause = cases; + cases = NULL; + } + else { + clause = Tree1(cases); + cases = Tree0(cases); + } + + /* + * Set up a failure store to capture the effects of failure + * of the selection clause. + */ + store = get_store(1); + fail_store = store; + infer_nd(Tree0(clause)); /* value of clause */ + + /* + * Create the effect of the possible failure of the comparison + * of the selection value to the control value. + */ + mrg_store(succ_store, fail_store); + + /* + * The success and failure stores and the result of the body + * of the clause are those of the whole case expression. + */ + fail_store = f_store; + infer_nd(Tree1(clause)); /* body of clause */ + mrg_store(succ_store, s_store); + free_store(succ_store); + succ_store = store; + if (n->store != NULL) + mrg_store(n->store, fail_store); /* 'case' can be resumed */ +#ifdef TypTrc + MrgTyp(n_intrtyp, Tree1(clause)->type, n->type); +#else /* TypTrc */ + /* + * Type is computed by case clause directly into n->type. + */ +#endif /* TypTrc */ + } + + /* + * Check for default clause. + */ + if (Tree2(n) == NULL) + mrg_store(succ_store, f_store); + else { + fail_store = f_store; + infer_nd(Tree2(n)); /* default */ + mrg_store(succ_store, s_store); + if (n->store != NULL) + mrg_store(n->store, fail_store); /* 'case' can be resumed */ +#ifdef TypTrc + MrgTyp(n_intrtyp, Tree2(n)->type, n->type); +#else /* TypTrc */ + /* + * Type is computed by default clause directly into n->type. + */ +#endif /* TypTrc */ + } + free_store(succ_store); + succ_store = s_store; + if (n->store != NULL) + fail_store = n->store; + break; + + case N_Create: + /* + * Record initial values of local variables for coexpression. + */ + store = coexp_map[n->new_types[0]]->in_store; + for (i = 0; i < n_loc; ++i) + ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], + store->types[n_gbl + i]) + /* + * Type is precomputed. + */ + break; + + case N_Cset: + case N_Empty: + case N_Id: + case N_Int: + case N_Real: + case N_Str: + /* + * Type is precomputed. + */ + break; + + case N_Field: { + struct fentry *fp; + struct par_rec *rp; + int frst_rec; + + if ((fp = flookup(Str0(Tree1(n)))) == NULL) { + break; /* error message printed elsewhere */ + } + + /* + * Determine the record types. + */ + infer_nd(Tree0(n)); + typ_deref(Tree0(n)->type, n->symtyps->types[0], 0); + + /* + * For each record containing this field, get the tupe of + * the field in that record. + */ + frst_rec = type_array[rec_typ].frst_bit; + for (rp = fp->rlist; rp != NULL; rp = rp->next) { + if (bitset(n->symtyps->types[0], frst_rec + rp->rec->rec_num)) + set_typ(n->type, frst_fld + rp->rec->frst_fld + rp->offset); + } + } + break; + + case N_If: + f_store = fail_store; + if (Tree2(n)->n_type != N_Empty) { + /* + * If there is an else clause, we must set up a failure store + * to capture the effects of failure of the control clause. + */ + store = get_store(1); + fail_store = store; + } + + infer_nd(Tree0(n)); /* control clause */ + + /* + * If the control clause succeeds, execution passes into the + * then clause with the failure store for the entire if expression. + */ + fail_store = f_store; + infer_nd(Tree1(n)); /* then clause */ + + if (Tree2(n)->n_type != N_Empty) { + if (n->store != NULL) + mrg_store(n->store, fail_store); /* 'if' expr can be resumed */ + s_store = succ_store; + + /* + * The entering success store of the else clause is the failure + * store of the control clause. The failure store is that of + * the entire if expression. + */ + succ_store = store; + fail_store = f_store; + infer_nd(Tree2(n)); /* else clause */ + + if (n->store != NULL) { + mrg_store(n->store, fail_store); /* 'if' expr can be resumed */ + fail_store = n->store; + } + + /* + * Join the exiting success stores of the then and else clauses. + */ + mrg_store(s_store, succ_store); + free_store(s_store); + } + +#ifdef TypTrc + MrgTyp(n_intrtyp, Tree1(n)->type, n->type); + if (Tree2(n)->n_type != N_Empty) + MrgTyp(n_intrtyp, Tree2(n)->type, n->type); +#else /* TypTrc */ + /* + * Type computed by 'then' and 'else' clauses directly into n->type. + */ +#endif /* TypTrc */ + break; + + case N_Invok: + /* + * General invocation. + */ + infer_nd(Tree1(n)); /* thing being invoked */ + + /* + * Perform type inference on all the arguments and copy the + * results into the argument type array. + */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = Val0(n); /* number of arguments */ + for (i = 0; i < num_args; ++i) { + infer_nd(n->n_field[i+2].n_ptr); /* arg i */ + arg_typs->types[i] = n->n_field[i+2].n_ptr->type; + } + + /* + * If this is mutual evaluation, get the type of the last argument, + * otherwise do inference on general invocation. + */ + if (Tree1(n)->n_type == N_Empty) { + MrgTyp(n_intrtyp, arg_typs->types[num_args - 1], n->type); + } + else + gen_inv(Tree1(n)->type, n); + + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + break; + + case N_InvOp: + /* + * Invocation of a run-time operation. Perform inference on all + * the arguments, copying the results into the argument type + * array. + */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = Val0(n); /* number of arguments */ + for (i = 0; i < num_args; ++i) { + infer_nd(n->n_field[i+2].n_ptr); /* arg i */ + arg_typs->types[i] = n->n_field[i+2].n_ptr->type; + } + + /* + * Perform inference on operation invocation. + */ + infer_impl(Impl1(n), n, n->symtyps, n->type); + chk_succ(Impl1(n)->ret_flag, n->store); + + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + break; + + case N_InvProc: + /* + * Invocation of a procedure. Perform inference on all + * the arguments, copying the results into the argument type + * array. + */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = Val0(n); /* number of arguments */ + for (i = 0; i < num_args; ++i) { + infer_nd(n->n_field[i+2].n_ptr); /* arg i */ + arg_typs->types[i] = n->n_field[i+2].n_ptr->type; + } + + /* + * Perform inference on the procedure invocation. + */ + infer_prc(Proc1(n), n); + chk_succ(Proc1(n)->ret_flag, n->store); + + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + break; + + case N_InvRec: + /* + * Invocation of a record constructor. Perform inference on all + * the arguments, copying the results into the argument type + * array. + */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = Val0(n); /* number of arguments */ + for (i = 0; i < num_args; ++i) { + infer_nd(n->n_field[i+2].n_ptr); /* arg i */ + arg_typs->types[i] = n->n_field[i+2].n_ptr->type; + } + + infer_con(Rec1(n), n); /* inference on constructor invocation */ + + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + break; + + case N_Limit: + infer_nd(Tree1(n)); /* limit */ + typ_deref(Tree1(n)->type, n->symtyps->types[0], 0); + mrg_store(succ_store, fail_store); /* limit might be 0 */ + mrg_store(n->store, fail_store); /* resumption may bypass expr */ + infer_nd(Tree0(n)); /* expression */ + if (fail_store != NULL) + mrg_store(n->store, fail_store); /* expression may be resumed */ + fail_store = n->store; + /* + * Type is computed by expression being limited. + */ + break; + + case N_Loop: { + /* + * Establish stores used by break and next. + */ + loop_info.prev = cur_loop; + loop_info.succ_store = get_store(1); + loop_info.fail_store = fail_store; + loop_info.next_store = NULL; + loop_info.susp_store = n->store->next; + cur_loop = &loop_info; + + switch ((int)Val0(Tree0(n))) { + case EVERY: + infer_nd(Tree1(n)); /* control clause */ + f_store = fail_store; + + /* + * Next in the do clause resumes the control clause as + * does success of the do clause. + */ + loop_info.next_store = fail_store; + infer_nd(Tree2(n)); /* do clause */ + mrg_store(succ_store, f_store); + break; + + case REPEAT: + /* + * The body of the loop can be entered by entering the + * loop, by executing a next in the body, or by having + * the loop succeed or fail. n->store captures all but + * the first case, which is covered by the initial success + * store. + */ + fail_store = n->store; + mrg_store(n->store, succ_store); + loop_info.next_store = n->store; + infer_nd(Tree1(n)); + mrg_store(succ_store, n->store); + break; + + case SUSPEND: + infer_nd(Tree1(n)); /* value */ +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) suspend ", n->n_file, n->n_line, + n->n_col); +#endif /* TypTrc */ + + set_ret(Tree1(n)->type); /* set return type of procedure */ + + /* + * Get changes to types of global variables from + * resumption. + */ + store = cur_proc->susp_store; + for (i = 0; i < n_gbl; ++i) + CpyTyp(n_icntyp, store->types[i], succ_store->types[i]); + + /* + * Next in the do clause resumes the control clause as + * does success of the do clause. + */ + f_store = fail_store; + loop_info.next_store = fail_store; + infer_nd(Tree2(n)); /* do clause */ + mrg_store(succ_store, f_store); + break; + + case WHILE: + /* + * The control clause can be entered by entering the loop, + * executing a next expression, or by having the do clause + * succeed or fail. n->store captures all but the first case, + * which is covered by the initial success store. + */ + mrg_store(n->store, succ_store); + loop_info.next_store = n->store; + infer_nd(Tree1(n)); /* control clause */ + fail_store = n->store; + infer_nd(Tree2(n)); /* do clause */ + mrg_store(succ_store, n->store); + break; + + case UNTIL: + /* + * The control clause can be entered by entering the loop, + * executing a next expression, or by having the do clause + * succeed or fail. n->store captures all but the first case, + * which is covered by the initial success store. + */ + mrg_store(n->store, succ_store); + loop_info.next_store = n->store; + f_store = fail_store; + /* + * Set up a failure store to capture the effects of failure + * of the control clause. + */ + store = get_store(1); + fail_store = store; + infer_nd(Tree1(n)); /* control clause */ + mrg_store(succ_store, f_store); + free_store(succ_store); + succ_store = store; + fail_store = n->store; + infer_nd(Tree2(n)); /* do clause */ + mrg_store(succ_store, n->store); + break; + } + free_store(succ_store); + succ_store = loop_info.succ_store; + if (n->store->next != NULL) + fail_store = n->store->next; + cur_loop = cur_loop->prev; + /* + * Type is computed by break expressions. + */ + } + break; + + case N_Next: + if (cur_loop->next_store == NULL) + mrg_store(succ_store, fail_store); /* control clause of every */ + else + mrg_store(succ_store, cur_loop->next_store); + free_store(succ_store); + succ_store = get_store(1); /* empty store says: can't get past here */ + fail_store = dummy_stor; /* shouldn't be used */ + /* + * Result is empty type. + */ + break; + + case N_Not: + /* + * Set up a failure store to capture the effects of failure + * of the negated expression, it becomes the success store + * of the entire expression. + */ + f_store = fail_store; + store = get_store(1); + fail_store = store; + infer_nd(Tree0(n)); + mrg_store(succ_store, f_store); /* if success, then fail */ + free_store(succ_store); + succ_store = store; + fail_store = f_store; + /* + * Type is precomputed. + */ + break; + + case N_Ret: + if (Val0(Tree0(n)) == RETURN) { + if (Tree1(n)->flag & CanFail) { + /* + * Set up a failure store to capture the effects of failure + * of the returned expression and the corresponding procedure + * failure. + */ + store = get_store(1); + fail_store = store; + infer_nd(Tree1(n)); /* return value */ + mrg_store(store, succ_store); + free_store(store); + } + else + infer_nd(Tree1(n)); /* return value */ + +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) return ", n->n_file, n->n_line, + n->n_col); +#endif /* TypTrc */ + + set_ret(Tree1(n)->type); + } + else { /* fail */ + set_ret(NULL); + +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) fail\n", n->n_file, n->n_line, + n->n_col); +#endif /* TypTrc */ + + } + free_store(succ_store); + succ_store = get_store(1); /* empty store says: can't get past here */ + fail_store = dummy_stor; /* shouldn't be used */ + /* + * Empty type. + */ + break; + + case N_Scan: { + struct implement *asgn_impl; + + infer_nd(Tree1(n)); /* subject */ + typ_deref(Tree1(n)->type, n->symtyps->types[0], 0); + infer_nd(Tree2(n)); /* body */ + + if (optab[Val0(Tree0(n))].tok.t_type == AUGQMARK) { + /* + * Perform type inference on the assignment. + */ + asgn_impl = optab[asgn_loc].binary; + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = 2; + arg_typs->types[0] = Tree1(n)->type; + arg_typs->types[1] = Tree2(n)->type; + infer_impl(asgn_impl, n, n->symtyps->next, n->type); + chk_succ(asgn_impl->ret_flag, n->store); + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + } + else + MrgTyp(n_intrtyp, Tree2(n)->type, n->type); + } + break; + + case N_Sect: + infer_nd(Tree2(n)); /* 1st operand */ + infer_nd(Tree3(n)); /* 2nd operand */ + infer_nd(Tree4(n)); /* 3rd operand */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + if (Impl1(n) != NULL) { + /* + * plus or minus. + */ + num_args = 2; + arg_typs->types[0] = Tree3(n)->type; + arg_typs->types[1] = Tree4(n)->type; + wktyp = get_wktyp(); + infer_impl(Impl1(n), n, n->symtyps->next, wktyp->bits); + chk_succ(Impl1(n)->ret_flag, n->store); + arg_typs->types[2] = wktyp->bits; + } + else + arg_typs->types[2] = Tree4(n)->type; + num_args = 3; + arg_typs->types[0] = Tree2(n)->type; + arg_typs->types[1] = Tree3(n)->type; + /* + * sectioning + */ + infer_impl(Impl0(n), n, n->symtyps, n->type); + chk_succ(Impl0(n)->ret_flag, n->store); + if (Impl1(n) != NULL) + free_wktyp(wktyp); + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + break; + + case N_Slist: + f_store = fail_store; + if (Tree0(n)->flag & CanFail) { + /* + * Set up a failure store to capture the effects of failure + * of the first operand; this is merged into the + * incoming success store of the second operand. + */ + store = get_store(1); + fail_store = store; + infer_nd(Tree0(n)); + mrg_store(store, succ_store); + free_store(store); + } + else + infer_nd(Tree0(n)); + fail_store = f_store; + infer_nd(Tree1(n)); + /* + * Type is computed by second operand. + */ + break; + + case N_SmplAsgn: { + /* + * Optimized assignment to a named variable. + */ + struct lentry *var; + int indx; + + infer_nd(Tree3(n)); + var = LSym0(Tree2(n)); + if (var->flag & F_Global) + indx = var->val.global->index; + else if (var->flag & F_Static) + indx = var->val.index; + else + indx = n_gbl + var->val.index; + ClrTyp(n_icntyp, succ_store->types[indx]); + typ_deref(Tree3(n)->type, succ_store->types[indx], 0); + +#ifdef TypTrc + /* + * Trace assignment. + */ + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) %s%s := ", n->n_file, n->n_line, + n->n_col, trc_indent, var->name); + prt_d_typ(trcfile, Tree3(n)->type); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + /* + * Type is precomputed. + */ + } + break; + + case N_SmplAug: { + /* + * Optimized augmented assignment to a named variable. + */ + struct lentry *var; + int indx; + + /* + * Perform type inference on the operation. + */ + infer_nd(Tree3(n)); /* 2nd operand */ + + /* + * Set up type array for arguments of operation. + */ + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = 2; + arg_typs->types[0] = Tree2(n)->type; /* type was precomputed */ + arg_typs->types[1] = Tree3(n)->type; + + /* + * Perform inference on the operation. + */ + infer_impl(Impl1(n), n, n->symtyps, Typ4(n)); + chk_succ(Impl1(n)->ret_flag, n->store); + + /* + * Perform assignment to the variable. + */ + var = LSym0(Tree2(n)); + if (var->flag & F_Global) + indx = var->val.global->index; + else if (var->flag & F_Static) + indx = var->val.index; + else + indx = n_gbl + var->val.index; + ClrTyp(n_icntyp, succ_store->types[indx]); + typ_deref(Typ4(n), succ_store->types[indx], 0); + +#ifdef TypTrc + /* + * Trace assignment. + */ + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) %s%s := ", n->n_file, n->n_line, + n->n_col, trc_indent, var->name); + prt_d_typ(trcfile, Typ4(n)); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + + /* + * Type is precomputed. + */ + } + break; + + default: + fprintf(stderr, "compiler error: node type %d unknown\n", n->n_type); + exit(EXIT_FAILURE); + } + } + +/* + * infer_con - perform type inference for the invocation of a record + * constructor. + */ +static void infer_con(rec, n) +struct rentry *rec; +nodeptr n; + { + int fld_indx; + int nfields; + int i; + +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) %s%s(", n->n_file, n->n_line, n->n_col, + trc_indent, rec->name); +#endif /* TypTrc */ + + /* + * Dereference argument types into appropriate entries of field store. + */ + fld_indx = rec->frst_fld; + nfields = rec->nfields; + for (i = 0; i < num_args && i < nfields; ++i) { + typ_deref(arg_typs->types[i], fld_stor->types[fld_indx++], 1); + +#ifdef TypTrc + if (trcfile != NULL) { + if (i > 0) + fprintf(trcfile, ", "); + prt_d_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + } + + /* + * If there are too few arguments, add null type to appropriate entries + * of field store. + */ + while (i < nfields) { + if (!bitset(fld_stor->types[fld_indx], null_bit)) { + ++changed; + set_typ(fld_stor->types[fld_indx], null_bit); + } + ++fld_indx; + ++i; + } + + /* + * return record type + */ + set_typ(n->type, type_array[rec_typ].frst_bit + rec->rec_num); + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, ") =>> "); + prt_typ(trcfile, n->type); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + } + +/* + * infer_act - perform type inference on coexpression activation. + */ +static void infer_act(n) +nodeptr n; + { + struct implement *asgn_impl; + struct store *s_store; + struct store *f_store; + struct store *e_store; + struct store *store; + struct t_coexpr *sv_coexp; + struct t_coexpr *coexp; + struct type *rslt_typ; + struct argtyps *sav_argtyp; + int frst_coexp; + int num_coexp; + int sav_nargs; + int i; + int j; + +#ifdef TypTrc + FILE *trc_save; +#endif /* TypTrc */ + + num_coexp = type_array[coexp_typ].num_bits; + frst_coexp = type_array[coexp_typ].frst_bit; + + infer_nd(Tree1(n)); /* value to transmit */ + infer_nd(Tree2(n)); /* coexpression */ + + /* + * Dereference the two arguments. Note that only locals in the + * transmitted value are dereferenced. + */ + +#ifdef TypTrc + trc_save = trcfile; + trcfile = NULL; /* don't trace value during dereferencing */ +#endif /* TypTrc */ + + deref_lcl(Tree1(n)->type, n->symtyps->types[0]); + +#ifdef TypTrc + trcfile = trc_save; +#endif /* TypTrc */ + + typ_deref(Tree2(n)->type, n->symtyps->types[1], 0); + + rslt_typ = get_wktyp(); + + /* + * Set up a store for the end of the activation and propagate local + * variables across the activation; the activation may succeed or + * fail. + */ + e_store = get_store(1); + for (i = 0; i < n_loc; ++i) + CpyTyp(n_icntyp, succ_store->types[n_gbl + i], e_store->types[n_gbl + i]) + if (fail_store->perm) { + for (i = 0; i < n_loc; ++i) + ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], + fail_store->types[n_gbl + i]) + } + else { + for (i = 0; i < n_loc; ++i) + MrgTyp(n_icntyp, succ_store->types[n_gbl + i], + fail_store->types[n_gbl + i]) + } + + + /* + * Go through all the co-expressions that might be activated, + * perform type inference on them, and transmit stores along + * the execution paths induced by the activation. + */ + s_store = succ_store; + f_store = fail_store; + for (j = 0; j < num_coexp; ++j) { + if (bitset(n->symtyps->types[1], frst_coexp + j)) { + coexp = coexp_map[j]; + /* + * Merge the types of global variables into the "in store" of the + * co-expression. Because the body of the co-expression may already + * have been processed for this pass, the "changed" flag must be + * set if there is a change of type in the store. This will insure + * that there will be another iteration in which to propagate the + * change into the body. + */ + store = coexp->in_store; + for (i = 0; i < n_gbl; ++i) + ChkMrgTyp(n_icntyp, s_store->types[i], store->types[i]) + + ChkMrgTyp(n_intrtyp, n->symtyps->types[0], coexp->act_typ) + + /* + * Only perform type inference on the body of a co-expression + * once per iteration. The main co-expression has no body. + */ + if (coexp->iteration < iteration & coexp->n != NULL) { + coexp->iteration = iteration; + succ_store = cpy_store(coexp->in_store); + fail_store = coexp->out_store; + sv_coexp = cur_coexp; + cur_coexp = coexp; + infer_nd(coexp->n); + + /* + * Dereference the locals in the value resulting from + * the execution of the co-expression body. + */ + +#ifdef TypTrc + if (trcfile != NULL) + fprintf(trcfile, "%s (%d,%d) %sC%d =>> ", coexp->n->n_file, + coexp->n->n_line, coexp->n->n_col, trc_indent, j); +#endif /* TypTrc */ + + deref_lcl(coexp->n->type, coexp->rslt_typ); + + mrg_store(succ_store, coexp->out_store); + free_store(succ_store); + cur_coexp = sv_coexp; + } + + /* + * Get updated types for global variables, assuming the co-expression + * fails or returns by completing. + */ + store = coexp->out_store; + for (i = 0; i < n_gbl; ++i) + MrgTyp(n_icntyp, store->types[i], e_store->types[i]); + if (f_store->perm) { + for (i = 0; i < n_gbl; ++i) + ChkMrgTyp(n_icntyp, store->types[i], f_store->types[i]); + } + else { + for (i = 0; i < n_gbl; ++i) + MrgTyp(n_icntyp, store->types[i], f_store->types[i]); + } + MrgTyp(n_intrtyp, coexp->rslt_typ, rslt_typ->bits) + } + } + + /* + * Control may return from the activation if another co-expression + * activates the current one. If we are in a create expression, + * cur_coexp is the current co-expression, otherwise the current + * procedure may be called within several co-expressions. + */ + if (cur_coexp == NULL) { + for (j = 0; j < num_coexp; ++j) + if (bitset(cur_proc->coexprs, frst_coexp + j)) + mrg_act(coexp_map[j], e_store, rslt_typ); + } + else + mrg_act(cur_coexp, e_store, rslt_typ); + + free_store(s_store); + succ_store = e_store; + fail_store = f_store; + + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) %s", n->n_file, n->n_line, n->n_col, + trc_indent); + prt_typ(trcfile, n->symtyps->types[0]); + fprintf(trcfile, " @ "); + prt_typ(trcfile, n->symtyps->types[1]); + fprintf(trcfile, " =>> "); + prt_typ(trcfile, rslt_typ->bits); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + + if (optab[Val0(Tree0(n))].tok.t_type == AUGAT) { + /* + * Perform type inference on the assignment. + */ + asgn_impl = optab[asgn_loc].binary; + sav_argtyp = arg_typs; + sav_nargs = num_args; + arg_typs = get_argtyp(); + num_args = 2; + arg_typs->types[0] = Tree1(n)->type; + arg_typs->types[1] = rslt_typ->bits; + infer_impl(asgn_impl, n, n->symtyps->next, n->type); + chk_succ(asgn_impl->ret_flag, n->store); + free_argtyp(arg_typs); + arg_typs = sav_argtyp; + num_args = sav_nargs; + } + else + ChkMrgTyp(n_intrtyp, rslt_typ->bits, n->type) + + free_wktyp(rslt_typ); + } + +/* + * mrg_act - merge entry information for the co-expression to the + * the ending store and result type for the activation being + * analyzed. + */ +static void mrg_act(coexp, e_store, rslt_typ) +struct t_coexpr *coexp; +struct store *e_store; +struct type *rslt_typ; + { + struct store *store; + int i; + + store = coexp->in_store; + for (i = 0; i < n_gbl; ++i) + MrgTyp(n_icntyp, store->types[i], e_store->types[i]); + + MrgTyp(n_intrtyp, coexp->act_typ, rslt_typ->bits) + } + +/* + * typ_deref - perform dereferencing in the abstract type realm. + */ +static void typ_deref(src, dest, chk) +#ifdef OptimizeType +struct typinfo *src; +struct typinfo *dest; +#else /* OptimizeType */ +unsigned int *src; +unsigned int *dest; +#endif /* OptimizeType */ +int chk; + { + struct store *tblel_stor; + struct store *tbldf_stor; + struct store *ttv_stor; + struct store *store; + unsigned int old; + int num_tbl; + int frst_tbl; + int num_bits; + int frst_bit; + int i; + int j; + int ret; +/* + if (src->bits == NULL) { + src->bits = alloc_mem_typ(src->size); + xfer_packed_types(src); + } + if (dest->bits == NULL) { + dest->bits = alloc_mem_typ(dest->size); + xfer_packed_types(dest); + } +*/ + /* + * copy values to destination + */ +#ifdef OptimizeType + if ((src->bits != NULL) && (dest->bits != NULL)) { + for (i = 0; i < NumInts(n_icntyp) - 1; ++i) { + old = dest->bits[i]; + dest->bits[i] |= src->bits[i]; + if (chk && (old != dest->bits[i])) + ++changed; + } + old = dest->bits[i]; + dest->bits[i] |= src->bits[i] & val_mask; /* mask out variables */ + if (chk && (old != dest->bits[i])) + ++changed; + } + else if ((src->bits != NULL) && (dest->bits == NULL)) { + dest->bits = alloc_mem_typ(DecodeSize(dest->packed)); + xfer_packed_types(dest); + for (i = 0; i < NumInts(n_icntyp) - 1; ++i) { + old = dest->bits[i]; + dest->bits[i] |= src->bits[i]; + if (chk && (old != dest->bits[i])) + ++changed; + } + old = dest->bits[i]; + dest->bits[i] |= src->bits[i] & val_mask; /* mask out variables */ + if (chk && (old != dest->bits[i])) + ++changed; + } + else if ((src->bits == NULL) && (dest->bits != NULL)) { + ret = xfer_packed_to_bits(src, dest, n_icntyp); + if (chk) + changed += ret; + } + else { + ret = mrg_packed_to_packed(src, dest, n_icntyp); + if (chk) + changed += ret; + } +#else /* OptimizeType */ + for (i = 0; i < NumInts(n_icntyp) - 1; ++i) { + old = dest[i]; + dest[i] |= src[i]; + if (chk && (old != dest[i])) + ++changed; + } + old = dest[i]; + dest[i] |= src[i] & val_mask; /* mask out variables */ + if (chk && (old != dest[i])) + ++changed; +#endif /* OptimizeType */ + + /* + * predefined variables whose types do not change. + */ + for (i = 0; i < num_typs; ++i) { + if (icontypes[i].deref == DrfCnst) { + if (bitset(src, type_array[i].frst_bit)) + if (chk) + ChkMrgTyp(n_icntyp, type_array[i].typ, dest) + else + MrgTyp(n_icntyp, type_array[i].typ, dest) + } + } + + + /* + * substring trapped variables + */ + num_bits = type_array[stv_typ].num_bits; + frst_bit = type_array[stv_typ].frst_bit; + for (i = 0; i < num_bits; ++i) + if (bitset(src, frst_bit + i)) + if (!bitset(dest, str_bit)) { + if (chk) + ++changed; + set_typ(dest, str_bit); + } + + /* + * table element trapped variables + */ + num_bits = type_array[ttv_typ].num_bits; + frst_bit = type_array[ttv_typ].frst_bit; + num_tbl = type_array[tbl_typ].num_bits; + frst_tbl = type_array[tbl_typ].frst_bit; + tblel_stor = compnt_array[tbl_val].store; + tbldf_stor = compnt_array[tbl_dflt].store; + ttv_stor = compnt_array[trpd_tbl].store; + for (i = 0; i < num_bits; ++i) + if (bitset(src, frst_bit + i)) + for (j = 0; j < num_tbl; ++j) + if (bitset(ttv_stor->types[i], frst_tbl + j)) { + if (chk) { + ChkMrgTyp(n_icntyp, tblel_stor->types[j], dest) + ChkMrgTyp(n_icntyp, tbldf_stor->types[j], dest) + } + else { + MrgTyp(n_icntyp, tblel_stor->types[j], dest) + MrgTyp(n_icntyp, tbldf_stor->types[j], dest) + } + } + + /* + * Aggregate compontents that are variables. + */ + for (i = 0; i < num_cmpnts; ++i) { + if (typecompnt[i].var) { + frst_bit = compnt_array[i].frst_bit; + num_bits = compnt_array[i].num_bits; + store = compnt_array[i].store; + for (j = 0; j < num_bits; ++j) { + if (bitset(src, frst_bit + j)) + if (chk) + ChkMrgTyp(n_icntyp, store->types[j], dest) + else + MrgTyp(n_icntyp, store->types[j], dest) + } + } + } + + + /* + * record fields + */ + for (i = 0; i < n_fld; ++i) + if (bitset(src, frst_fld + i)) { + if (chk) + ChkMrgTyp(n_icntyp, fld_stor->types[i], dest) + else + MrgTyp(n_icntyp, fld_stor->types[i], dest) + } + + /* + * global variables + */ + for (i = 0; i < n_gbl; ++i) + if (bitset(src, frst_gbl + i)) { + if (chk) + ChkMrgTyp(n_icntyp, succ_store->types[i], dest) + else + MrgTyp(n_icntyp, succ_store->types[i], dest) + } + + /* + * local variables + */ + for (i = 0; i < n_loc; ++i) + if (bitset(src, frst_loc + i)) { + if (chk) + ChkMrgTyp(n_icntyp, succ_store->types[n_gbl + i], dest) + else + MrgTyp(n_icntyp, succ_store->types[n_gbl + i], dest) + } +} + +/* + * infer_impl - perform type inference on a call to built-in operation + * using the implementation entry from the data base. + */ +static void infer_impl(impl, n, symtyps, rslt_typ) +struct implement *impl; +nodeptr n; +struct symtyps *symtyps; +#ifdef OptimizeType +struct typinfo *rslt_typ; +#else /* OptimizeType */ +unsigned int *rslt_typ; +#endif /* OptimizeType */ + { +#ifdef OptimizeType + struct typinfo *typ; +#else /* OptimizeType */ + unsigned int *typ; +#endif /* OptimizeType */ + int flag; + int nparms; + int i; + int j; + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) %s", n->n_file, n->n_line, n->n_col, + trc_indent); + if (impl->oper_typ == 'K') + fprintf(trcfile, "&%s", impl->name); + else + fprintf(trcfile, "%s(", impl->name); + } +#endif /* TypTrc */ + /* + * Set up the "symbol table" of dereferenced and undereferenced + * argument types as needed by the operation. + */ + nparms = impl->nargs; + j = 0; + for (i = 0; i < num_args && i < nparms; ++i) { + if (impl->arg_flgs[i] & RtParm) { + CpyTyp(n_intrtyp, arg_typs->types[i], symtyps->types[j]); + +#ifdef TypTrc + if (trcfile != NULL) { + if (i > 0) + fprintf(trcfile, ", "); + prt_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + ++j; + } + if (impl->arg_flgs[i] & DrfPrm) { + typ_deref(arg_typs->types[i], symtyps->types[j], 0); + +#ifdef TypTrc + if (trcfile != NULL) { + if (impl->arg_flgs[i] & RtParm) + fprintf(trcfile, "->"); + else if (i > 0) + fprintf(trcfile, ", "); + prt_d_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + ++j; + } + } + if (nparms > 0) { + /* + * Check for varargs. Merge remaining arguments into the + * type of the variable part of the parameter list. + */ + flag = impl->arg_flgs[nparms - 1]; + if (flag & VarPrm) { + n_vararg = num_args - nparms + 1; + if (n_vararg < 0) + n_vararg = 0; + typ = symtyps->types[j - 1]; + while (i < num_args) { + if (flag & RtParm) { + MrgTyp(n_intrtyp, arg_typs->types[i], typ) + +#ifdef TypTrc + if (trcfile != NULL) { + if (i > 0) + fprintf(trcfile, ", "); + prt_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + } + else { + typ_deref(arg_typs->types[i], typ, 0); + +#ifdef TypTrc + if (trcfile != NULL) { + if (i > 0) + fprintf(trcfile, ", "); + prt_d_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + } + ++i; + } + nparms -= 1; /* Don't extend with nulls into variable part */ + } + } + while (i < nparms) { + if (impl->arg_flgs[i] & RtParm) + set_typ(symtyps->types[j++], null_bit); /* Extend args with nulls */ + if (impl->arg_flgs[i] & DrfPrm) + set_typ(symtyps->types[j++], null_bit); /* Extend args with nulls */ + ++i; + } + + /* + * If this operation can suspend, there may be backtracking paths + * to this invocation. Merge type information from those paths + * into the current store. + */ + if (impl->ret_flag & DoesSusp) + mrg_store(n->store, succ_store); + + cur_symtyps = symtyps; + cur_rslt.bits = rslt_typ; + cur_rslt.size = n_intrtyp; + cur_new = n->new_types; + infer_il(impl->in_line); /* perform inference on operation */ + + if (MightFail(impl->ret_flag)) + mrg_store(succ_store, fail_store); + +#ifdef TypTrc + if (trcfile != NULL) { + if (impl->oper_typ != 'K') + fprintf(trcfile, ")"); + fprintf(trcfile, " =>> "); + prt_typ(trcfile, rslt_typ); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + } + +/* + * chk_succ - check to see if the operation can succeed. In particular, + * see if it can suspend. Change the succ_store and failure store + * appropriately. + */ +static void chk_succ(ret_flag, susp_stor) +int ret_flag; +struct store *susp_stor; + { + if (ret_flag & DoesSusp) { + if (susp_stor != NULL && (ret_flag & DoesRet)) + mrg_store(susp_stor, fail_store); /* "pass along" failure */ + fail_store = susp_stor; + } + else if (!(ret_flag & DoesRet)) { + free_store(succ_store); + succ_store = get_store(1); + fail_store = dummy_stor; /* shouldn't be used */ + } + } + +/* + * infer_il - perform type inference on a piece of code within built-in + * operation and determine whether execution can get past it. + */ +static int infer_il(il) +struct il_code *il; + { + struct il_code *il1; + int condition; + int case_fnd; + int ncases; + int may_fallthru; + int indx; + int i; + + if (il == NULL) + return 1; + + switch (il->il_type) { + case IL_Const: /* should have been replaced by literal node */ + return 0; + + case IL_If1: + condition = eval_cond(il->u[0].fld); + may_fallthru = (condition & MaybeFalse); + if (condition & MaybeTrue) + may_fallthru |= infer_il(il->u[1].fld); + return may_fallthru; + + case IL_If2: + condition = eval_cond(il->u[0].fld); + may_fallthru = 0; + if (condition & MaybeTrue) + may_fallthru |= infer_il(il->u[1].fld); + if (condition & MaybeFalse) + may_fallthru |= infer_il(il->u[2].fld); + return may_fallthru; + + case IL_Tcase1: + type_case(il, infer_il, NULL); + return 1; /* no point in trying very hard here */ + + case IL_Tcase2: + indx = type_case(il, infer_il, NULL); + if (indx != -1) + infer_il(il->u[indx].fld); /* default */ + return 1; /* no point in trying very hard here */ + + case IL_Lcase: + ncases = il->u[0].n; + indx = 1; + case_fnd = 0; + for (i = 0; i < ncases && !case_fnd; ++i) { + if (il->u[indx++].n == n_vararg) { /* selection number */ + infer_il(il->u[indx].fld); /* action */ + case_fnd = 1; + } + ++indx; + } + if (!case_fnd) + infer_il(il->u[indx].fld); /* default */ + return 1; /* no point in trying very hard here */ + + case IL_Acase: { + int maybe_int; + int maybe_dbl; + + eval_arith((int)il->u[0].fld->u[0].n, (int)il->u[1].fld->u[0].n, + &maybe_int, &maybe_dbl); + if (maybe_int) { + infer_il(il->u[2].fld); /* C_integer action */ + if (largeints) + infer_il(il->u[3].fld); /* integer action */ + } + if (maybe_dbl) + infer_il(il->u[4].fld); /* C_double action */ + return 1; /* no point in trying very hard here */ + } + + case IL_Err1: + case IL_Err2: + return 0; + + case IL_Block: + return il->u[0].n; + + case IL_Call: + return ((il->u[3].n & DoesFThru) != 0); + + case IL_Lst: + if (infer_il(il->u[0].fld)) + return infer_il(il->u[1].fld); + else + return 0; + + case IL_Abstr: + /* + * Handle side effects. + */ + il1 = il->u[0].fld; + if (il1 != NULL) { + while (il1->il_type == IL_Lst) { + side_effect(il1->u[1].fld); + il1 = il1->u[0].fld; + } + side_effect(il1); + } + + /* + * Set return type. + */ + abstr_typ(il->u[1].fld, &cur_rslt); + return 1; + + default: + fprintf(stderr, "compiler error: unknown info in data base\n"); + exit(EXIT_FAILURE); + /* NOTREACHED */ + } + } + +/* + * side_effect - perform a side effect from an abstract clause of a + * built-in operation. + */ +static void side_effect(il) +struct il_code *il; + { + struct type *var_typ; + struct type *val_typ; + struct store *store; + int num_bits; + int frst_bit; + int i, j; + + /* + * il is IL_TpAsgn, get the variable type and value type, and perform + * the side effect. + */ + var_typ = get_wktyp(); + val_typ = get_wktyp(); + abstr_typ(il->u[0].fld, var_typ); /* variable type */ + abstr_typ(il->u[1].fld, val_typ); /* value type */ + + /* + * Determine which types that can be assigned to are in the variable + * type. + * + * Aggregate compontents. + */ + for (i = 0; i < num_cmpnts; ++i) { + frst_bit = compnt_array[i].frst_bit; + num_bits = compnt_array[i].num_bits; + store = compnt_array[i].store; + for (j = 0; j < num_bits; ++j) { + if (bitset(var_typ->bits, frst_bit + j)) + ChkMrgTyp(n_icntyp, val_typ->bits, store->types[j]) + } + } + + /* + * record fields + */ + for (i = 0; i < n_fld; ++i) + if (bitset(var_typ->bits, frst_fld + i)) + ChkMrgTyp(n_icntyp, val_typ->bits, fld_stor->types[i]); + + /* + * global variables + */ + for (i = 0; i < n_gbl; ++i) + if (bitset(var_typ->bits, frst_gbl + i)) + MrgTyp(n_icntyp, val_typ->bits, succ_store->types[i]); + + /* + * local variables + */ + for (i = 0; i < n_loc; ++i) + if (bitset(var_typ->bits, frst_loc + i)) + MrgTyp(n_icntyp, val_typ->bits, succ_store->types[n_gbl + i]); + + + free_wktyp(var_typ); + free_wktyp(val_typ); + } + +/* + * abstr_typ - compute the type bits corresponding to an abstract type + * from an abstract clause of a built-in operation. + */ +static void abstr_typ(il, typ) +struct il_code *il; +struct type *typ; + { + struct type *typ1; + struct type *typ2; + struct rentry *rec; + struct store *store; + struct compnt_info *compnts; + int num_bits; + int frst_bit; + int frst_cmpnt; + int num_comps; + int typcd; + int new_indx; + int i; + int j; + int indx; + int size; + int t_indx; +#ifdef OptimizeType + struct typinfo *prmtyp; +#else /* OptimizeType */ + unsigned int *prmtyp; +#endif /* OptimizeType */ + + if (il == NULL) + return; + + switch (il->il_type) { + case IL_VarTyp: + /* + * type() + */ + indx = il->u[0].fld->u[0].n; /* symbol table index of variable */ + if (indx >= cur_symtyps->nsyms) { + prmtyp = any_typ; + size = n_rttyp; + } + else { + prmtyp = cur_symtyps->types[indx]; + size = n_intrtyp; + } + if (typ->size < size) + size = typ->size; + MrgTyp(size, prmtyp, typ->bits); + break; + + case IL_Store: + /* + * store[] + */ + typ1 = get_wktyp(); + abstr_typ(il->u[0].fld, typ1); /* type to be "dereferenced" */ + + /* + * Dereference types that are Icon varaibles. + */ + typ_deref(typ1->bits, typ->bits, 0); + + /* + * "Dereference" aggregate compontents that are not Icon variables. + */ + for (i = 0; i < num_cmpnts; ++i) { + if (!typecompnt[i].var) { + if (i == stv_typ) { + /* + * Substring trapped variable stores contain variable + * references, so the types are larger, but we cannot + * copy more than the destination holds. + */ + size = n_intrtyp; + if (typ->size < size) + size = typ->size; + } + else + size = n_icntyp; + frst_bit = compnt_array[i].frst_bit; + num_bits = compnt_array[i].num_bits; + store = compnt_array[i].store; + for (j = 0; j < num_bits; ++j) { + if (bitset(typ1->bits, frst_bit + j)) + MrgTyp(size, store->types[j], typ->bits); + } + } + } + + free_wktyp(typ1); + break; + + case IL_Compnt: + /* + * . + */ + typ1 = get_wktyp(); + abstr_typ(il->u[0].fld, typ1); /* type */ + i = il->u[1].n; + if (i == CM_Fields) { + /* + * The all_fields component must be handled differently + * from the others. + */ + frst_bit = type_array[rec_typ].frst_bit; + num_bits = type_array[rec_typ].num_bits; + for (i = 0; i < num_bits; ++i) + if (bitset(typ1->bits, frst_bit + i)) { + rec = rec_map[i]; + for (j = 0; j < rec->nfields; ++j) + set_typ(typ->bits, frst_fld + rec->frst_fld + j); + } + } + else { + /* + * Use component information arrays to transform type bits to + * the corresponding component bits. + */ + frst_bit = type_array[typecompnt[i].aggregate].frst_bit; + num_bits = type_array[typecompnt[i].aggregate].num_bits; + frst_cmpnt = compnt_array[i].frst_bit; + if (!typecompnt[i].var && typ->size < n_rttyp) + break; /* bad abstract type computation */ + for (i = 0; i < num_bits; ++i) + if (bitset(typ1->bits, frst_bit + i)) + set_typ(typ->bits, frst_cmpnt + i); + free_wktyp(typ1); + } + break; + + case IL_Union: + /* + * ++ + */ + abstr_typ(il->u[0].fld, typ); + abstr_typ(il->u[1].fld, typ); + break; + + case IL_Inter: + /* + * ** + */ + typ1 = get_wktyp(); + typ2 = get_wktyp(); + abstr_typ(il->u[0].fld, typ1); + abstr_typ(il->u[1].fld, typ2); + size = n_rttyp; +#ifdef OptimizeType + and_bits_to_packed(typ2->bits, typ1->bits, size); +#else /* OptimizeType */ + for (i = 0; i < NumInts(size); ++i) + typ1->bits[i] &= typ2->bits[i]; +#endif /* OptimizeType */ + if (typ->size < size) + size = typ->size; + MrgTyp(size, typ1->bits, typ->bits); + free_wktyp(typ1); + free_wktyp(typ2); + break; + + case IL_New: + /* + * new ( , ...) + * + * If a type was not allocated for this node, use the default + * one. + */ + typ1 = get_wktyp(); + typcd = il->u[0].n; /* type code */ + new_indx = type_array[typcd].new_indx; + t_indx = 0; /* default is first index of type */ + if (cur_new != NULL && cur_new[new_indx] > 0) + t_indx = cur_new[new_indx]; + + /* + * This RTL expression evaluates to the "new" sub-type. + */ + set_typ(typ->bits, type_array[typcd].frst_bit + t_indx); + + /* + * Update stores for components based on argument types in the + * "new" expression. + */ + num_comps = icontypes[typcd].num_comps; + j = icontypes[typcd].compnts; + compnts = &compnt_array[j]; + if (typcd == stv_typ) { + size = n_intrtyp; + } + else + size = n_icntyp; + for (i = 0; i < num_comps; ++i) { + ClrTyp(n_rttyp, typ1->bits); + abstr_typ(il->u[2 + i].fld, typ1); + ChkMrgTyp(size, typ1->bits, compnts[i].store->types[t_indx]); + } + + free_wktyp(typ1); + break; + + case IL_IcnTyp: + typcd_bits((int)il->u[0].n, typ); /* type code */ + break; + } + } + +/* + * eval_cond - evaluate the condition of in 'if' statement from a + * built-in operation. The result can be both true and false because + * of uncertainty and because more than one execution path may be + * involved. + */ +static int eval_cond(il) +struct il_code *il; + { + int cond1; + int cond2; + + switch (il->il_type) { + case IL_Bang: + cond1 = eval_cond(il->u[0].fld); + cond2 = 0; + if (cond1 & MaybeTrue) + cond2 = MaybeFalse; + if (cond1 & MaybeFalse) + cond2 |= MaybeTrue; + return cond2; + + case IL_And: + cond1 = eval_cond(il->u[0].fld); + cond2 = eval_cond(il->u[1].fld); + return (cond1 & cond2 & MaybeTrue) | ((cond1 | cond2) & MaybeFalse); + + case IL_Cnv1: + case IL_Cnv2: + return eval_cnv((int)il->u[0].n, (int)il->u[1].fld->u[0].n, + 0, NULL); + + case IL_Def1: + case IL_Def2: + return eval_cnv((int)il->u[0].n, (int)il->u[1].fld->u[0].n, + 1, NULL); + + case IL_Is: + return eval_is((int)il->u[0].n, il->u[1].fld->u[0].n); + + default: + fprintf(stderr, "compiler error: unknown info in data base\n"); + exit(EXIT_FAILURE); + /* NOTREACHED */ + } + } + +/* + * eval_cnv - evaluate the conversion of a variable to a specific type + * to see if it may succeed or fail. + */ +int eval_cnv(typcd, indx, def, cnv_flags) +int typcd; /* type to convert to */ +int indx; /* index into symbol table of variable */ +int def; /* flag: conversion has a default value */ +int *cnv_flags; /* return flag for detailed conversion information */ + { + struct type *may_succeed; /* types where conversion sometimes succeed */ + struct type *must_succeed; /* types where conversion always succeeds */ + struct type *must_cnv; /* types where actual conversion is performed */ + struct type *as_is; /* types where value already has correct type */ +#ifdef OptimizeType + struct typinfo *typ; /* possible types of the variable */ +#else /* OptimizeType */ + unsigned int *typ; +#endif /* OptimizeType */ + int cond; + int i; +#ifdef OptimizeType + unsigned int val1, val2; +#endif /* OptimizeType */ + + /* + * Conversions may succeed for strings, integers, csets, and reals. + * Conversions may fail for any other types. In addition, + * conversions to integer or real may fail for specific values. + */ + if (indx >= cur_symtyps->nsyms) + return MaybeTrue | MaybeFalse; + typ = cur_symtyps->types[indx]; + + may_succeed = get_wktyp(); + must_succeed = get_wktyp(); + must_cnv = get_wktyp(); + as_is = get_wktyp(); + + if (typcd == cset_typ || typcd == TypTCset) { + set_typ(as_is->bits, cset_bit); + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, int_bit); + set_typ(must_cnv->bits, real_bit); + + set_typ(must_succeed->bits, str_bit); + set_typ(must_succeed->bits, cset_bit); + set_typ(must_succeed->bits, int_bit); + set_typ(must_succeed->bits, real_bit); + } + else if (typcd == str_typ || typcd == TypTStr) { + set_typ(as_is->bits, str_bit); + + set_typ(must_cnv->bits, cset_bit); + set_typ(must_cnv->bits, int_bit); + set_typ(must_cnv->bits, real_bit); + + set_typ(must_succeed->bits, str_bit); + set_typ(must_succeed->bits, cset_bit); + set_typ(must_succeed->bits, int_bit); + set_typ(must_succeed->bits, real_bit); + } + else if (typcd == TypCStr) { + /* + * as_is is empty. + */ + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + set_typ(must_cnv->bits, int_bit); + set_typ(must_cnv->bits, real_bit); + + set_typ(must_succeed->bits, str_bit); + set_typ(must_succeed->bits, cset_bit); + set_typ(must_succeed->bits, int_bit); + set_typ(must_succeed->bits, real_bit); + } + else if (typcd == real_typ) { + set_typ(as_is->bits, real_bit); + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + set_typ(must_cnv->bits, int_bit); + + set_typ(must_succeed->bits, int_bit); + set_typ(must_succeed->bits, real_bit); + } + else if (typcd == TypCDbl) { + /* + * as_is is empty. + */ + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + set_typ(must_cnv->bits, int_bit); + set_typ(must_cnv->bits, real_bit); + + set_typ(must_succeed->bits, int_bit); + set_typ(must_succeed->bits, real_bit); + } + else if (typcd == int_typ) { + set_typ(as_is->bits, int_bit); + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + set_typ(must_cnv->bits, real_bit); + + set_typ(must_succeed->bits, int_bit); + } + else if (typcd == TypCInt) { + /* + * Note that conversion from an integer to a C integer can be + * done by changing the way the descriptor is accessed. It + * is not considered a real conversion. Conversion may fail + * even for integers if large integers are supported. + */ + set_typ(as_is->bits, int_bit); + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + set_typ(must_cnv->bits, real_bit); + + if (!largeints) + set_typ(must_succeed->bits, int_bit); + } + else if (typcd == TypEInt) { + set_typ(as_is->bits, int_bit); + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + + set_typ(must_succeed->bits, int_bit); + } + else if (typcd == TypECInt) { + set_typ(as_is->bits, int_bit); + + set_typ(must_cnv->bits, str_bit); + set_typ(must_cnv->bits, cset_bit); + + if (!largeints) + set_typ(must_succeed->bits, int_bit); + } + + MrgTyp(n_icntyp, as_is->bits, may_succeed->bits); + MrgTyp(n_icntyp, must_cnv->bits, may_succeed->bits); + if (def) { + set_typ(may_succeed->bits, null_bit); + set_typ(must_succeed->bits, null_bit); + } + + /* + * Determine if the conversion expression may evaluate to true or false. + */ + cond = 0; + +/* + if (typ->bits == NULL) { + typ->bits = alloc_mem_typ(typ->size); + xfer_packed_types(typ); + } + if (may_succeed->bits->bits == NULL) { + may_succeed->bits->bits = alloc_mem_typ(may_succeed->bits->size); + xfer_packed_types(may_succeed->bits); + } + if (must_succeed->bits->bits == NULL) { + must_succeed->bits->bits = alloc_mem_typ(must_succeed->bits->size); + xfer_packed_types(must_succeed->bits); + } +*/ + for (i = 0; i < NumInts(n_intrtyp); ++i) { +#ifdef OptimizeType + if ((typ->bits != NULL) && (may_succeed->bits->bits != NULL)) { + if (typ->bits[i] & may_succeed->bits->bits[i]) + cond = MaybeTrue; + } + else if ((typ->bits == NULL) && (may_succeed->bits->bits != NULL)) { + val1 = get_bit_vector(typ, i); + if (val1 & may_succeed->bits->bits[i]) + cond = MaybeTrue; + } + else if ((typ->bits != NULL) && (may_succeed->bits->bits == NULL)) { + val2 = get_bit_vector(may_succeed->bits, i); + if (typ->bits[i] & val2) + cond = MaybeTrue; + } + else { + val1 = get_bit_vector(typ, i); + val2 = get_bit_vector(may_succeed->bits, i); + if (val1 & val2) + cond = MaybeTrue; + } + if ((typ->bits != NULL) && (must_succeed->bits->bits != NULL)) { + if (typ->bits[i] & ~must_succeed->bits->bits[i]) + cond |= MaybeFalse; + } + else if ((typ->bits == NULL) && (must_succeed->bits->bits != NULL)) { + val1 = get_bit_vector(typ, i); + if (val1 & ~must_succeed->bits->bits[i]) + cond |= MaybeFalse; + } + else if ((typ->bits != NULL) && (must_succeed->bits->bits == NULL)) { + val2 = get_bit_vector(must_succeed->bits, i); + if (typ->bits[i] & ~val2) + cond |= MaybeFalse; + } + else { + val1 = get_bit_vector(typ, i); + val2 = get_bit_vector(must_succeed->bits, i); + if (val1 & ~val2) + cond |= MaybeFalse; + } +#else /* OptimizeType */ + if (typ[i] & may_succeed->bits[i]) + cond = MaybeTrue; + if (typ[i] & ~must_succeed->bits[i]) + cond |= MaybeFalse; +#endif /* OptimizeType */ + } + + /* + * See if more detailed information about the conversion is needed. + */ + if (cnv_flags != NULL) { + *cnv_flags = 0; +/* + if (as_is->bits == NULL) { + as_is->bits->bits = alloc_mem_typ(as_is->bits->size); + xfer_packed_types(as_is->bits); + } + if (must_cnv->bits->bits == NULL) { + must_cnv->bits->bits = alloc_mem_typ(must_cnv->bits->size); + xfer_packed_types(must_cnv->bits); + } +*/ + for (i = 0; i < NumInts(n_intrtyp); ++i) { +#ifdef OptimizeType + if ((typ->bits != NULL) && (as_is->bits->bits != NULL)) { + if (typ->bits[i] & as_is->bits->bits[i]) + *cnv_flags |= MayKeep; + } + else if ((typ->bits == NULL) && (as_is->bits->bits != NULL)) { + val1 = get_bit_vector(typ, i); + if (val1 & as_is->bits->bits[i]) + *cnv_flags |= MayKeep; + } + else if ((typ->bits != NULL) && (as_is->bits->bits == NULL)) { + val2 = get_bit_vector(as_is->bits, i); + if (typ->bits[i] & val2) + *cnv_flags |= MayKeep; + } + else { + val1 = get_bit_vector(typ, i); + val2 = get_bit_vector(as_is->bits, i); + if (val1 & val2) + *cnv_flags |= MayKeep; + } + if ((typ->bits != NULL) && (must_cnv->bits->bits != NULL)) { + if (typ->bits[i] & must_cnv->bits->bits[i]) + *cnv_flags |= MayConvert; + } + else if ((typ->bits == NULL) && (must_cnv->bits->bits != NULL)) { + val1 = get_bit_vector(typ, i); + if (val1 & must_cnv->bits->bits[i]) + *cnv_flags |= MayConvert; + } + else if ((typ->bits != NULL) && (must_cnv->bits->bits == NULL)) { + val2 = get_bit_vector(must_cnv->bits, i); + if (typ->bits[i] & val2) + *cnv_flags |= MayConvert; + } + else { + val1 = get_bit_vector(typ, i); + val2 = get_bit_vector(must_cnv->bits, i); + if (val1 & val2) + *cnv_flags |= MayConvert; + } +#else /* OptimizeType */ + if (typ[i] & as_is->bits[i]) + *cnv_flags |= MayKeep; + if (typ[i] & must_cnv->bits[i]) + *cnv_flags |= MayConvert; +#endif /* OptimizeType */ + } + if (def && bitset(typ, null_bit)) + *cnv_flags |= MayDefault; + } + + free_wktyp(may_succeed); + free_wktyp(must_succeed); + free_wktyp(must_cnv); + free_wktyp(as_is); + + return cond; + } + +/* + * eval_is - evaluate the result of an 'is' expression within a built-in + * operation. + */ +int eval_is(typcd, indx) +int typcd; +int indx; + { + int cond; +#ifdef OptimizeType + struct typinfo *typ; +#else /* OptimizeType */ + unsigned int *typ; +#endif /* OptimizeType */ + + if (indx >= cur_symtyps->nsyms) + return MaybeTrue | MaybeFalse; + typ = cur_symtyps->types[indx]; + if (has_type(typ, typcd, 0)) + cond = MaybeTrue; + else + cond = 0; + if (other_type(typ, typcd)) + cond |= MaybeFalse; + return cond; + } + +/* + * eval_arith - determine which cases of an arith_case may be taken based + * on the types of its arguments. + */ +void eval_arith(indx1, indx2, maybe_int, maybe_dbl) +int indx1; +int indx2; +int *maybe_int; +int *maybe_dbl; + { +#ifdef OptimizeType + struct typinfo *typ1; /* possible types of first variable */ + struct typinfo *typ2; /* possible types of second variable */ +#else /* OptimizeType */ + unsigned int *typ1; /* possible types of first variable */ + unsigned int *typ2; /* possible types of second variable */ +#endif /* OptimizeType */ + int int1 = 0; + int int2 = 0; + int dbl1 = 0; + int dbl2 = 0; + + typ1 = cur_symtyps->types[indx1]; + typ2 = cur_symtyps->types[indx2]; + + /* + * First see what might result if you do a convert to numeric on each + * variable. + */ + if (bitset(typ1, int_bit)) + int1 = 1; + if (bitset(typ1, real_bit)) + dbl1 = 1; + if (bitset(typ1, str_bit) || bitset(typ1, cset_bit)) { + int1 = 1; + dbl1 = 1; + } + if (bitset(typ2, int_bit)) + int2 = 1; + if (bitset(typ2, real_bit)) + dbl2 = 1; + if (bitset(typ2, str_bit) || bitset(typ2, cset_bit)) { + int2 = 1; + dbl2 = 1; + } + + /* + * Use the conversion information to figure out what type of arithmetic + * might be done. + */ + if (int1 && int2) + *maybe_int = 1; + else + *maybe_int = 0; + + *maybe_dbl = 0; + if (dbl1 && dbl2) + *maybe_dbl = 1; + else if (dbl1 && int2) + *maybe_dbl = 1; + else if (int1 && dbl2) + *maybe_dbl = 1; + } + +/* + * type_case - Determine which cases are selected in a type_case + * statement. This routine is used by both type inference and + * the code generator: a different fnc is passed in each case. + * In addition, the code generator passes a case_anlz structure. + */ +int type_case(il, fnc, case_anlz) +struct il_code *il; +int (*fnc)(); +struct case_anlz *case_anlz; + { + int *typ_vect; + int i, j; + int num_cases; + int num_types; + int indx; + int sym_indx; + int typcd; + int use_dflt; +#ifdef OptimizeType + struct typinfo *typ; +#else /* OptimizeType */ + unsigned int *typ; +#endif /* OptimizeType */ + int select; + struct type *wktyp; + + /* + * Make a copy of the type of the variable the type case is + * working on. + */ + sym_indx = il->u[0].fld->u[0].n; /* symbol table index */ + if (sym_indx >= cur_symtyps->nsyms) + typ = any_typ; /* variable is not a parameter, don't know type */ + else + typ = cur_symtyps->types[sym_indx]; + wktyp = get_wktyp(); + CpyTyp(n_intrtyp, typ, wktyp->bits); + typ = wktyp->bits; + + /* + * Loop through all the case clauses. + */ + num_cases = il->u[1].n; + indx = 2; + for (i = 0; i < num_cases; ++i) { + /* + * For each of the types selected by this clause, see if the variable's + * type bit vector contains that type and delete the type from the + * bit vector (so we know if we need the default when we are done). + */ + num_types = il->u[indx++].n; + typ_vect = il->u[indx++].vect; + select = 0; + for (j = 0; j < num_types; ++j) + if (has_type(typ, typ_vect[j], 1)) { + typcd = typ_vect[j]; + select += 1; + } + + if (select > 0) { + fnc(il->u[indx].fld); /* action */ + + /* + * If this routine was called by the code generator, we need to + * return extra information. + */ + if (case_anlz != NULL) { + ++case_anlz->n_cases; + if (select == 1) { + if (case_anlz->il_then == NULL) { + case_anlz->typcd = typcd; + case_anlz->il_then = il->u[indx].fld; + } + else if (case_anlz->il_else == NULL) + case_anlz->il_else = il->u[indx].fld; + } + else { + /* + * There is more than one possible type that will cause + * us to select this case. It can only be used in the "else". + */ + if (case_anlz->il_else == NULL) + case_anlz->il_else = il->u[indx].fld; + else + case_anlz->n_cases = 3; /* force no inlining. */ + } + } + } + ++indx; + } + + /* + * If there are types that have not been handled, indicate this by + * returning the index of the default clause. + */ + use_dflt = 0; + for (i = 0; i < n_intrtyp; ++i) + if (bitset(typ, i)) { + use_dflt = 1; + break; + } + free_wktyp(wktyp); + if (use_dflt) + return indx; + else + return -1; + } + +/* + * gen_inv - general invocation. The argument list is set up, perform + * abstract interpretation on each possible things being invoked. + */ +static void gen_inv(typ, n) +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ +nodeptr n; + { + int ret_flag = 0; + struct store *s_store; + struct store *store; + struct gentry *gptr; + struct implement *ip; + struct type *prc_typ; + int frst_prc; + int num_prcs; + int i; + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) {\n", n->n_file, n->n_line, n->n_col); + trc_indent = " "; + } +#endif /* TypTrc */ + + frst_prc = type_array[proc_typ].frst_bit; + num_prcs = type_array[proc_typ].num_bits; + + /* + * Dereference the type of the thing being invoked. + */ + prc_typ = get_wktyp(); + typ_deref(typ, prc_typ->bits, 0); + + s_store = succ_store; + store = get_store(1); + + if (bitset(prc_typ->bits, str_bit) || + bitset(prc_typ->bits, cset_bit) || + bitset(prc_typ->bits, int_bit) || + bitset(prc_typ->bits, real_bit)) { + /* + * Assume integer invocation; any argument may be the result type. + */ + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) %s{i}(", n->n_file, n->n_line, n->n_col, + trc_indent); + } +#endif /* TypTrc */ + + for (i = 0; i < num_args; ++i) { + MrgTyp(n_intrtyp, arg_typs->types[i], n->type); + +#ifdef TypTrc + if (trcfile != NULL) { + if (i > 0) + fprintf(trcfile, ", "); + prt_typ(trcfile, arg_typs->types[i]); + } +#endif /* TypTrc */ + + } + + /* + * Integer invocation may succeed or fail. + */ + ret_flag |= DoesRet | DoesFail; + mrg_store(s_store, store); + mrg_store(s_store, fail_store); + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, ") =>> "); + prt_typ(trcfile, n->type); + fprintf(trcfile, "\n"); + } +#endif /* TypTrc */ + } + + if (bitset(prc_typ->bits, str_bit) || + bitset(prc_typ->bits, cset_bit)) { + /* + * Assume string invocation; add all procedure types to the thing + * being invoked. + */ + for (i = 0; i < num_prcs; ++i) + set_typ(prc_typ->bits, frst_prc + i); + } + + if (bitset(prc_typ->bits, frst_prc)) { + /* + * First procedure type represents all operators that are + * available via string invocation. Scan the operator table + * looking for those that are in the string invocation table. + * Note, this is not particularly efficient or precise. + */ + for (i = 0; i < IHSize; ++i) + for (ip = ohash[i]; ip != NULL; ip = ip->blink) + if (ip->iconc_flgs & InStrTbl) { + succ_store = cpy_store(s_store); + infer_impl(ip, n, n->symtyps, n->type); + ret_flag |= ip->ret_flag; + mrg_store(succ_store, store); + free_store(succ_store); + } + } + + /* + * Check for procedure, built-in, and record constructor types + * and perform type inference on invocations of them. + */ + for (i = 1; i < num_prcs; ++i) + if (bitset(prc_typ->bits, frst_prc + i)) { + succ_store = cpy_store(s_store); + gptr = proc_map[i]; + switch (gptr->flag & (F_Proc | F_Builtin | F_Record)) { + case F_Proc: + infer_prc(gptr->val.proc, n); + ret_flag |= gptr->val.proc->ret_flag; + break; + case F_Builtin: + infer_impl(gptr->val.builtin, n, n->symtyps, n->type); + ret_flag |= gptr->val.builtin->ret_flag; + break; + case F_Record: + infer_con(gptr->val.rec, n); + ret_flag |= DoesRet | (err_conv ? DoesFail : 0); + break; + } + mrg_store(succ_store, store); + free_store(succ_store); + } + + /* + * If error conversion is supported and a non-procedure value + * might be invoked, assume the invocation can fail. + */ + if (err_conv && other_type(prc_typ->bits, proc_typ)) + mrg_store(s_store, fail_store); + + free_store(s_store); + succ_store = store; + chk_succ(ret_flag, n->store); + + free_wktyp(prc_typ); + +#ifdef TypTrc + if (trcfile != NULL) { + fprintf(trcfile, "%s (%d,%d) }\n", n->n_file, n->n_line, n->n_col); + trc_indent = ""; + } +#endif /* TypTrc */ + } + +/* + * get_wktyp - get a dynamically allocated bit vector to use as a + * work area for doing type computations. + */ +static struct type *get_wktyp() + { + struct type *typ; + + if ((typ = type_pool) == NULL) { + typ = NewStruct(type); + typ->size = n_rttyp; + typ->bits = alloc_typ(n_rttyp); + } + else { + type_pool = type_pool->next; + ClrTyp(n_rttyp, typ->bits); + } + return typ; + } + +/* + * free_wktyp - free a dynamically allocated type bit vector. + */ +static void free_wktyp(typ) +struct type *typ; + { + typ->next = type_pool; + type_pool = typ; + } + +#ifdef TypTrc + +/* + * ChkSep - supply a separating space if this is not the first item. + */ +#define ChkSep(n) (++n > 1 ? " " : "") + +/* + * prt_typ - print a type that can include variable references. + */ +static void prt_typ(file, typ) +FILE *file; +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ + { + struct gentry *gptr; + struct lentry *lptr; + char *name; + int i, j, k; + int n; + int frst_bit; + int num_bits; + char *abrv; + + fprintf(trcfile, "{"); + n = 0; + /* + * Go through the types and see any sub-types are present. + */ + for (k = 0; k < num_typs; ++k) { + frst_bit = type_array[k].frst_bit; + num_bits = type_array[k].num_bits; + abrv = icontypes[k].abrv; + if (k == proc_typ) { + /* + * procedures, record constructors, and built-in functions. + */ + for (i = 0; i < num_bits; ++i) + if (bitset(typ, frst_bit + i)) { + if (i == 0) + fprintf(file, "%sops", ChkSep(n)); + else { + gptr = proc_map[i]; + switch (gptr->flag & (F_Proc | F_Builtin | F_Record)) { + case F_Proc: + fprintf(file, "%s%s:%s", ChkSep(n), abrv, gptr->name); + break; + case F_Builtin: + fprintf(file, "%sfnc:%s", ChkSep(n), gptr->name); + break; + case F_Record: + fprintf(file, "%sconstr:%s", ChkSep(n), gptr->name); + break; + } + } + } + } + else if (k == rec_typ) { + /* + * records - include record name. + */ + for (i = 0; i < num_bits; ++i) + if (bitset(typ, frst_bit + i)) + fprintf(file, "%s%s:%s", ChkSep(n), abrv, rec_map[i]->name); + } + else if (icontypes[k].support_new | k == coexp_typ) { + /* + * A type with sub-types. + */ + for (i = 0; i < num_bits; ++i) + if (bitset(typ, frst_bit + i)) + fprintf(file, "%s%s%d", ChkSep(n), abrv, i); + } + else { + /* + * A type with no subtypes. + */ + if (bitset(typ, frst_bit)) + fprintf(file, "%s%s", ChkSep(n), abrv); + } + } + + for (k = 0; k < num_cmpnts; ++k) { + if (typecompnt[k].var) { + /* + * Structure component that is a variable. + */ + frst_bit = compnt_array[k].frst_bit; + num_bits = compnt_array[k].num_bits; + abrv = typecompnt[k].abrv; + for (i = 0; i < num_bits; ++i) + if (bitset(typ, frst_bit + i)) + fprintf(file, "%s%s%d", ChkSep(n), abrv, i); + } + } + + + /* + * record fields + */ + for (i = 0; i < n_fld; ++i) + if (bitset(typ, frst_fld + i)) + fprintf(file, "%sfld%d", ChkSep(n), i); + + /* + * global variables + */ + for (i = 0; i < n_nmgbl; ++i) + if (bitset(typ, frst_gbl + i)) { + name = NULL; + for (j = 0; j < GHSize && name == NULL; j++) + for (gptr = ghash[j]; gptr != NULL && name == NULL; + gptr = gptr->blink) + if (gptr->index == i) + name = gptr->name; + for (lptr = cur_proc->statics; lptr != NULL && name == NULL; + lptr = lptr->next) + if (lptr->val.index == i) + name = lptr->name; + /* + * Static variables may be returned and dereferenced in a procedure + * they don't belong to. + */ + if (name == NULL) + name = "?static?"; + fprintf(file, "%svar:%s", ChkSep(n), name); + } + + /* + * local variables + */ + for (i = 0; i < n_loc; ++i) + if (bitset(typ, frst_loc + i)) { + name = NULL; + for (lptr = cur_proc->args; lptr != NULL && name == NULL; + lptr = lptr->next) + if (lptr->val.index == i) + name = lptr->name; + for (lptr = cur_proc->dynams; lptr != NULL && name == NULL; + lptr = lptr->next) + if (lptr->val.index == i) + name = lptr->name; + /* + * Local variables types may appear in the wrong procedure due to + * substring trapped variables and the inference of impossible + * execution paths. Make sure we don't end up with a NULL name. + */ + if (name == NULL) + name = "?"; + fprintf(file, "%svar:%s", ChkSep(n), name); + } + + fprintf(trcfile, "}"); + } + +/* + * prt_d_typ - dereference a type and print it. + */ +static void prt_d_typ(file, typ) +FILE *file; +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ +{ + struct type *wktyp; + + wktyp = get_wktyp(); + typ_deref(typ, wktyp->bits, 0); + prt_typ(file, wktyp->bits); + free_wktyp(wktyp); +} +#endif /* TypTrc */ + +/* + * get_argtyp - get an array of pointers to type bit vectors for use + * in constructing an argument list. The array is large enough for the + * largest argument list. + */ +static struct argtyps *get_argtyp() + { + struct argtyps *argtyps; + + if ((argtyps = argtyp_pool) == NULL) +#ifdef OptimizeType + argtyps = (struct argtyps *)alloc((unsigned int)(sizeof(struct argtyps) + + ((max_prm - 1) * sizeof(struct typinfo *)))); +#else /* OptimizeType */ + argtyps = (struct argtyps *)alloc((unsigned int)(sizeof(struct argtyps) + + ((max_prm - 1) * sizeof(unsigned int *)))); +#endif /* OptimizeType */ + else + argtyp_pool = argtyp_pool->next; + return argtyps; + } + +/* + * free_argtyp - free array of pointers to type bitvectors. + */ +static void free_argtyp(argtyps) +struct argtyps *argtyps; + { + argtyps->next = argtyp_pool; + argtyp_pool = argtyps; + } + +/* + * varsubtyp - examine a type and determine what kinds of variable + * subtypes it has and whether it has any non-variable subtypes. + * If the type consists of a single named variable, return its symbol + * table entry through the parameter "singl". + */ +int varsubtyp(typ, singl) +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ +struct lentry **singl; + { + struct store *stv_stor; + int subtypes; + int n_types; + int var_indx; + int frst_bit; + int num_bits; + int i, j; + + + subtypes = 0; + n_types = 0; + var_indx = -1; + + /* + * check for non-variables. + */ + for (i = 0; i < n_icntyp; ++i) + if (bitset(typ, i)) { + subtypes |= HasVal; + ++n_types; + } + + /* + * Predefined variable types. + */ + for (i = 0; i < num_typs; ++i) { + if (icontypes[i].deref != DrfNone) { + frst_bit = type_array[i].frst_bit; + num_bits = type_array[i].num_bits; + for (j = 0; j < num_bits; ++j) { + if (bitset(typ, frst_bit + j)) { + if (i == stv_typ) { + /* + * We have found substring trapped variable j, see whether it + * references locals or globals. + */ + if (do_typinfer) { + stv_stor = compnt_array[str_var].store; + subtypes |= varsubtyp(stv_stor->types[j], NULL); + } + else + subtypes |= HasLcl | HasPrm | HasGlb; + } + else + subtypes |= HasGlb; + ++n_types; + } + } + } + } + + /* + * Aggregate compontents that are variables. + */ + for (i = 0; i < num_cmpnts; ++i) { + if (typecompnt[i].var) { + frst_bit = compnt_array[i].frst_bit; + num_bits = compnt_array[i].num_bits; + for (j = 0; j < num_bits; ++j) { + if (bitset(typ, frst_bit + j)) { + subtypes |= HasGlb; + ++n_types; + } + } + } + } + + /* + * record fields + */ + for (i = 0; i < n_fld; ++i) + if (bitset(typ, frst_fld + i)) { + subtypes |= HasGlb; + ++n_types; + } + + /* + * global variables, including statics + */ + for (i = 0; i < n_gbl; ++i) { + if (bitset(typ, frst_gbl + i)) { + subtypes |= HasGlb; + var_indx = i; + ++n_types; + } + } + + /* + * local variables + */ + for (i = 0; i < n_loc; ++i) { + if (bitset(typ, frst_loc + i)) { + if (i < Abs(cur_proc->nargs)) + subtypes |= HasPrm; + else + subtypes |= HasLcl; + var_indx = n_gbl + i; + ++n_types; + } + } + + if (singl != NULL) { + /* + * See if the type consists of a single named variable. + */ + if (n_types == 1 && var_indx != -1) + *singl = cur_proc->vartypmap[var_indx]; + else + *singl = NULL; + } + + return subtypes; + } + +/* + * mark_recs - go through the list of parent records for this field + * and mark those that are in the type. Also gather information + * to help generate better code. + */ +void mark_recs(fp, typ, num_offsets, offset, bad_recs) +struct fentry *fp; +#ifdef OptimizeType +struct typinfo *typ; +#else /* OptimizeType */ +unsigned int *typ; +#endif /* OptimizeType */ +int *num_offsets; +int *offset; +int *bad_recs; + { + struct par_rec *rp; + struct type *wktyp; + int frst_rec; + + *num_offsets = 0; + *offset = -1; + *bad_recs = 0; + + wktyp = get_wktyp(); + CpyTyp(n_icntyp, typ, wktyp->bits); + + /* + * For each record containing this field, see if the record is + * in the type. + */ + frst_rec = type_array[rec_typ].frst_bit; + for (rp = fp->rlist; rp != NULL; rp = rp->next) { + if (bitset(wktyp->bits, frst_rec + rp->rec->rec_num)) { + /* + * This record is in the type. + */ + rp->mark = 1; + clr_typ(wktyp->bits, frst_rec + rp->rec->rec_num); + if (*offset != rp->offset) { + *offset = rp->offset; + *num_offsets += 1; + } + } + } + + /* + * Are there any records that do not contain this field? + */ + *bad_recs = has_type(wktyp->bits, rec_typ, 0); + free_wktyp(wktyp); + } + +/* + * past_prms - return true if execution might continue past the parameter + * evaluation. If a parameter has no type, this will not happen. + */ +int past_prms(n) +nodeptr n; + { + struct implement *impl; + struct symtyps *symtyps; + int nparms; + int nargs; + int flag; + int i, j; + + nargs = Val0(n); + impl = Impl1(n); + symtyps = n->symtyps; + nparms = impl->nargs; + + if (symtyps == NULL) + return 1; + + j = 0; + for (i = 0; i < nparms; ++i) { + flag = impl->arg_flgs[i]; + if (flag & VarPrm && i >= nargs) + break; /* no parameters for variable part of arg list */ + if (flag & RtParm) { + if (is_empty(symtyps->types[j])) + return 0; + ++j; + } + if (flag & DrfPrm) { + if (is_empty(symtyps->types[j])) + return 0; + ++j; + } + } + return 1; + } diff --git a/src/icont/Makefile b/src/icont/Makefile new file mode 100644 index 0000000..8f15f9d --- /dev/null +++ b/src/icont/Makefile @@ -0,0 +1,108 @@ +# Makefile for the Icon translator, icont. + +include ../../Makedefs + + +HFILES = ../h/define.h ../h/config.h ../h/cpuconf.h ../h/gsupport.h \ + ../h/mproto.h ../h/typedefs.h ../h/cstructs.h + +TRANS = trans.o tcode.o tlex.o lnklist.o tparse.o tsym.o tmem.o tree.o + +LINKR = link.o lglob.o lcode.o llex.o lmem.o lsym.o opcode.o + +OBJS = tunix.o tglobals.o util.o $(TRANS) $(LINKR) + +COBJS = ../common/long.o ../common/getopt.o ../common/alloc.o \ + ../common/filepart.o ../common/strtbl.o ../common/ipp.o \ + ../common/munix.o + + + +icont: $(OBJS) $(COBJS) + $(CC) $(CFLAGS) $(LDFLAGS) -o icont $(OBJS) $(COBJS) + cp icont ../../bin + strip ../../bin/icont$(EXE) + (cd ../../bin; rm -f icon; ln -s icont icon) + +$(OBJS): $(HFILES) tproto.h + +$(COBJS): $(HFILES) + cd ../common; $(MAKE) + +tunix.o: tglobals.h ../h/version.h +tglobals.o: tglobals.h +util.o: tglobals.h tree.h ../h/fdefs.h + +# translator files +trans.o: tglobals.h tsym.h ttoken.h tree.h ../h/version.h ../h/kdefs.h +lnklist.o: lfile.h +tparse.o: ../h/lexdef.h tglobals.h tsym.h tree.h keyword.h +tcode.o: tglobals.h tsym.h ttoken.h tree.h +tlex.o: ../h/lexdef.h ../h/parserr.h ttoken.h tree.h ../h/esctab.h \ + ../common/lextab.h ../common/yylex.h ../common/error.h +tmem.o: tglobals.h tsym.h tree.h +tree.o: tree.h +tsym.o: tglobals.h tsym.h ttoken.h lfile.h keyword.h ../h/kdefs.h + +# linker files +$(LINKR): link.h lfile.h ../h/rt.h ../h/sys.h ../h/monitor.h \ + ../h/rstructs.h ../h/rmacros.h ../h/rexterns.h + +link.o: tglobals.h hdr.h ../h/header.h +lcode.o: tglobals.h opcode.h keyword.h ../h/header.h \ + ../h/opdefs.h ../h/version.h +lglob.o: tglobals.h opcode.h ../h/opdefs.h ../h/version.h +llex.o: tglobals.h opcode.h ../h/opdefs.h +lmem.o: tglobals.h +lsym.o: tglobals.h +opcode.o: opcode.h ../h/opdefs.h + +# hdr.h is always built, to simplify the Makefile, +# but it is only actually used if BinHeader is define. +hdr.h: newhdr ixhdr.hdr + ./newhdr -o hdr.h ixhdr.hdr +newhdr: newhdr.c ../h/define.h ../h/config.h ../h/gsupport.h + $(CC) $(CFLAGS) $(LDFLAGS) -o newhdr newhdr.c +ixhdr.hdr: ixhdr.c ../h/define.h ../h/config.h ../h/header.h $(COBJS) + $(CC) $(CFLAGS) $(LDFLAGS) -o ixhdr.hdr \ + ixhdr.c ../common/alloc.o ../common/munix.o + strip ixhdr.hdr + + + + +# The following sections are commented out because they do not need to be +# performed unless changes are made to cgrammar.c, ../h/grammar.h, +# ../common/tokens.txt, or ../common/op.txt. Such changes involve +# modifications to the syntax of Icon and are not part of the installation +# process. However, if the distribution files are unloaded in a fashion +# such that their dates are not set properly, the following sections would +# be attempted. +# +# Note that if any changes are made to the files mentioned above, the comment +# characters at the beginning of the following lines should be removed. +# icont must be on your search path for these actions to work. +# +#../common/lextab.h ../common/yacctok.h ../common/fixgram ../common/pscript: \ +# ../common/tokens.txt ../common/op.txt +# cd ../common; $(MAKE) gfiles +# +#tparse.c ttoken.h: tgram.g trash ../common/pscript +## expect 218 shift/reduce conflicts +# yacc -d tgram.g +# ./trash tparse.c +# mv y.tab.h ttoken.h +# rm -f y.tab.c +# +#tgram.g: tgrammar.c ../h/define.h ../h/grammar.h \ +# ../common/yacctok.h ../common/fixgram +# $(CC) -E -C tgrammar.c | ../common/fixgram >tgram.g +# +#../h/kdefs.h keyword.h: ../runtime/keyword.r mkkwd +# ./mkkwd <../runtime/keyword.r +# +#trash: trash.icn +# icont -s trash.icn +# +#mkkwd: mkkwd.icn +# icont -s mkkwd.icn diff --git a/src/icont/ixhdr.c b/src/icont/ixhdr.c new file mode 100644 index 0000000..9766292 --- /dev/null +++ b/src/icont/ixhdr.c @@ -0,0 +1,73 @@ +/* + * ixhdr.c -- bootstrap header for icode files + * + * (used when BinaryHeader is defined) + */ + +#include "../h/gsupport.h" + +static void doiconx (char *argv[]); +static void hsyserr (char *av, char *file); + +int main(int argc, char *argv[]) { + char *argvx[1000]; + + /* + * Abort if we've been invoked with setuid or setgid privileges. + * Allowing such usage would open a huge security hole, because + * there is no way to ensure that the right iconx will interpret + * the right user program. + */ + if (getuid() != geteuid() || getgid() != getegid()) + hsyserr(argv[0], ": cannot run an Icon program setuid/setgid"); + + /* + * Shift the argument list to make room for iconx in argv[0]. + */ + do + argvx[argc + 1] = argv[argc]; + while (argc--); + + /* + * Pass the arglist and execute iconx. + */ + doiconx(argvx); + return EXIT_FAILURE; + } + +/* + * doiconx(argv) - execute iconx, passing argument list. + * + * To find the interpreter, first check the environment variable ICONX. + * If it defines a path, it had better work, else we abort. + * + * Failing that, check the directory containing the icode file, + * and if that doesn't work, search $PATH. + */ +static void doiconx(char *argv[]) { + char xcmd[256]; + + if ((argv[0] = getenv("ICONX")) != NULL && argv[0][0] != '\0') { + execv(argv[0], argv); /* exec file specified by $ICONX */ + hsyserr("cannot execute $ICONX: ", argv[0]); + } + + argv[0] = relfile(argv[1], "/../iconx" ExecSuffix); + execv(argv[0], argv); /* try iconx in same dir; just continue if absent */ + + if (findonpath("iconx" ExecSuffix, xcmd, sizeof(xcmd))) { + argv[0] = xcmd; + execv(xcmd, argv); + hsyserr("cannot execute ", xcmd); + } + + hsyserr(argv[1], ": cannot find iconx" ExecSuffix); + } + +/* + * hsyserr(s1, s2) - print s1 and s2 on stderr, then abort. + */ +static void hsyserr(char *s1, char *s2) { + fprintf(stderr, "%s%s\n", s1, s2); + exit(EXIT_FAILURE); + } diff --git a/src/icont/keyword.h b/src/icont/keyword.h new file mode 100644 index 0000000..f6659c1 --- /dev/null +++ b/src/icont/keyword.h @@ -0,0 +1,70 @@ +/* + * keyword.h -- Keyword manifest constants. + * + * Created mechanically by mkkwd.icn -- DO NOT EDIT. + */ + +#define K_ALLOCATED 1 +#define K_ASCII 2 +#define K_CLOCK 3 +#define K_COL 4 +#define K_COLLECTIONS 5 +#define K_COLUMN 6 +#define K_CONTROL 7 +#define K_CSET 8 +#define K_CURRENT 9 +#define K_DATE 10 +#define K_DATELINE 11 +#define K_DIGITS 12 +#define K_DUMP 13 +#define K_E 14 +#define K_ERROR 15 +#define K_ERRORNUMBER 16 +#define K_ERRORTEXT 17 +#define K_ERRORVALUE 18 +#define K_ERROUT 19 +#define K_EVENTCODE 20 +#define K_EVENTSOURCE 21 +#define K_EVENTVALUE 22 +#define K_FAIL 23 +#define K_FEATURES 24 +#define K_FILE 25 +#define K_HOST 26 +#define K_INPUT 27 +#define K_INTERVAL 28 +#define K_LCASE 29 +#define K_LDRAG 30 +#define K_LETTERS 31 +#define K_LEVEL 32 +#define K_LINE 33 +#define K_LPRESS 34 +#define K_LRELEASE 35 +#define K_MAIN 36 +#define K_MDRAG 37 +#define K_META 38 +#define K_MPRESS 39 +#define K_MRELEASE 40 +#define K_NULL 41 +#define K_OUTPUT 42 +#define K_PHI 43 +#define K_PI 44 +#define K_POS 45 +#define K_PROGNAME 46 +#define K_RANDOM 47 +#define K_RDRAG 48 +#define K_REGIONS 49 +#define K_RESIZE 50 +#define K_ROW 51 +#define K_RPRESS 52 +#define K_RRELEASE 53 +#define K_SHIFT 54 +#define K_SOURCE 55 +#define K_STORAGE 56 +#define K_SUBJECT 57 +#define K_TIME 58 +#define K_TRACE 59 +#define K_UCASE 60 +#define K_VERSION 61 +#define K_WINDOW 62 +#define K_X 63 +#define K_Y 64 diff --git a/src/icont/lcode.c b/src/icont/lcode.c new file mode 100644 index 0000000..a1481f1 --- /dev/null +++ b/src/icont/lcode.c @@ -0,0 +1,1564 @@ +/* + * lcode.c -- linker routines to parse .u1 files and produce icode. + */ + +#include "link.h" +#include "tproto.h" +#include "tglobals.h" +#include "opcode.h" +#include "keyword.h" +#include "../h/version.h" +#include "../h/header.h" + +/* + * This needs fixing ... + */ +#undef CsetPtr +#define CsetPtr(b,c) ((c) + (((b)&0377) >> LogIntBits)) + +/* + * Prototypes. + */ + +static void align (void); +static void backpatch (int lab); +static void clearlab (void); +static void flushcode (void); +static void intout (int oint); +static void lemit (int op,char *name); +static void lemitcon (int k); +static void lemitin (int op,word offset,int n,char *name); +static void lemitint (int op,long i,char *name); +static void lemitl (int op,int lab,char *name); +static void lemitn (int op,word n,char *name); +static void lemitproc (word name,int nargs,int ndyn,int nstat,int fstat); +static void lemitr (int op,word loc,char *name); +static void misalign (void); +static void outblock (char *addr,int count); +static void setfile (void); +static void wordout (word oword); + +#ifdef FieldTableCompression + static void charout (unsigned char oint); + static void shortout (short oint); +#endif /* FieldTableCompression */ + +#ifdef DeBugLinker + static void dumpblock (char *addr,int count); +#endif /* DeBugLinker */ + +word pc = 0; /* simulated program counter */ + +#define outword(n) wordout((word)(n)) +#define outop(n) intout((int)(n)) +#define outchar(n) charout((unsigned char)(n)) +#define outshort(n) shortout((short)(n)) +#define CodeCheck(n) if ((long)codep + (n) > (long)((long)codeb + maxcode))\ + codeb = (char *) trealloc(codeb, &codep, &maxcode, 1,\ + (n), "code buffer"); + +#define ByteBits 8 + +/* + * gencode - read .u1 file, resolve variable references, and generate icode. + * Basic process is to read each line in the file and take some action + * as dictated by the opcode. This action sometimes involves parsing + * of arguments and usually culminates in the call of the appropriate + * lemit* routine. + */ +void gencode() + { + register int op, k, lab; + int j, nargs, flags, implicit; + char *name; + word id, procname; + struct centry *cp; + struct gentry *gp; + struct fentry *fp; + union xval gg; + + while ((op = getopc(&name)) != EOF) { + switch (op) { + + /* Ternary operators. */ + + case Op_Toby: + case Op_Sect: + + /* Binary operators. */ + + case Op_Asgn: + case Op_Cat: + case Op_Diff: + case Op_Div: + case Op_Eqv: + case Op_Inter: + case Op_Lconcat: + case Op_Lexeq: + case Op_Lexge: + case Op_Lexgt: + case Op_Lexle: + case Op_Lexlt: + case Op_Lexne: + case Op_Minus: + case Op_Mod: + case Op_Mult: + case Op_Neqv: + case Op_Numeq: + case Op_Numge: + case Op_Numgt: + case Op_Numle: + case Op_Numlt: + case Op_Numne: + case Op_Plus: + case Op_Power: + case Op_Rasgn: + case Op_Rswap: + case Op_Subsc: + case Op_Swap: + case Op_Unions: + + /* Unary operators. */ + + case Op_Bang: + case Op_Compl: + case Op_Neg: + case Op_Nonnull: + case Op_Null: + case Op_Number: + case Op_Random: + case Op_Refresh: + case Op_Size: + case Op_Tabmat: + case Op_Value: + + /* Instructions. */ + + case Op_Bscan: + case Op_Ccase: + case Op_Coact: + case Op_Cofail: + case Op_Coret: + case Op_Dup: + case Op_Efail: + case Op_Eret: + case Op_Escan: + case Op_Esusp: + case Op_Limit: + case Op_Lsusp: + case Op_Pfail: + case Op_Pnull: + case Op_Pop: + case Op_Pret: + case Op_Psusp: + case Op_Push1: + case Op_Pushn1: + case Op_Sdup: + newline(); + lemit(op, name); + break; + + case Op_Chfail: + case Op_Create: + case Op_Goto: + case Op_Init: + lab = getlab(); + newline(); + lemitl(op, lab, name); + break; + + case Op_Cset: + case Op_Real: + k = getdec(); + newline(); + lemitr(op, lctable[k].c_pc, name); + break; + + case Op_Field: + id = getid(); + newline(); + fp = flocate(id); + if (fp != NULL) + lemitn(op, (word)(fp->f_fid-1), name); + else + lemitn(op, (word)-1, name); /* no warning any more */ + break; + + + case Op_Int: { + long i; + k = getdec(); + newline(); + cp = &lctable[k]; + /* + * Check to see if a large integers has been converted to a string. + * If so, generate the code for +s. + */ + if (cp->c_flag & F_StrLit) { + lemit(Op_Pnull,"pnull"); + lemitin(Op_Str, cp->c_val.sval, cp->c_length, "str"); + lemit(Op_Number,"number"); + break; + } + i = (long)cp->c_val.ival; + lemitint(op, i, name); + break; + } + + + case Op_Invoke: + k = getdec(); + newline(); + if (k == -1) + lemit(Op_Apply,"apply"); + else + lemitn(op, (word)k, name); + break; + + case Op_Keywd: + id = getstr(); + newline(); + k = klookup(&lsspace[id]); + switch (k) { + case 0: + lfatal(&lsspace[id],"invalid keyword"); + break; + case K_FAIL: + lemit(Op_Efail,"efail"); + break; + case K_NULL: + lemit(Op_Pnull,"pnull"); + break; + default: + lemitn(op, (word)k, name); + } + break; + + case Op_Llist: + k = getdec(); + newline(); + lemitn(op, (word)k, name); + break; + + case Op_Lab: + lab = getlab(); + newline(); + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "L%d:\n", lab); + #endif /* DeBugLinker */ + backpatch(lab); + break; + + case Op_Line: + /* + * Line number change. + * All the interesting stuff happens in Op_Colm now. + */ + lineno = getdec(); + + #ifndef SrcColumnInfo + /* + * Enter the value in the line number table + * that is stored in the icode file and used during error + * handling and execution monitoring. One can generate a VM + * instruction for these changes, but since the numbers are not + * saved and restored during backtracking, it is more accurate + * to check for line number changes in-line in the interpreter. + * Fortunately, the in-line check is about as fast as executing + * Op_Line instructions. All of this is complicated by the use + * of Op_Line to generate Noop instructions when enabled by the + * LineCodes #define. + * + * If SrcColumnInfo is required, this code is duplicated, + * with changes, in the Op_Colm case below. + */ + if (lnfree >= &lntable[nsize]) + lntable = (struct ipc_line *)trealloc(lntable,&lnfree,&nsize, + sizeof(struct ipc_line), 1, "line number table"); + lnfree->ipc = pc; + lnfree->line = lineno; + lnfree++; + #endif /* SrcColumnInfo */ + + /* + * Could generate an Op_Line for monitoring, but don't anymore: + * + * lemitn(op, (word)lineno, name); + */ + + newline(); + + #ifdef LineCodes + #ifndef EventMon + lemit(Op_Noop,"noop"); + #endif /* EventMon */ + #endif /* LineCodes */ + + break; + + case Op_Colm: /* always recognize, maybe ignore */ + + colmno = getdec(); + #ifdef SrcColumnInfo + if (lnfree >= &lntable[nsize]) + lntable = (struct ipc_line *)trealloc(lntable,&lnfree,&nsize, + sizeof(struct ipc_line), 1, "line number table"); + lnfree->ipc = pc; + lnfree->line = lineno + (colmno << 16); + lnfree++; + #endif /* SrcColumnInfo */ + break; + + case Op_Mark: + lab = getlab(); + newline(); + lemitl(op, lab, name); + break; + + case Op_Mark0: + lemit(op, name); + break; + + case Op_Str: + k = getdec(); + newline(); + cp = &lctable[k]; + lemitin(op, cp->c_val.sval, cp->c_length, name); + break; + + case Op_Tally: + k = getdec(); + newline(); + lemitn(op, (word)k, name); + break; + + case Op_Unmark: + lemit(Op_Unmark, name); + break; + + case Op_Var: + k = getdec(); + newline(); + flags = lltable[k].l_flag; + if (flags & F_Global) + lemitn(Op_Global, (word)(lltable[k].l_val.global->g_index), + "global"); + else if (flags & F_Static) + lemitn(Op_Static, (word)(lltable[k].l_val.staticid-1), "static"); + else if (flags & F_Argument) + lemitn(Op_Arg, (word)(lltable[k].l_val.offset-1), "arg"); + else + lemitn(Op_Local, (word)(lltable[k].l_val.offset-1), "local"); + break; + + /* Declarations. */ + + case Op_Proc: + getstr(); + newline(); + procname = putident(strlen(&lsspace[lsfree]) + 1, 0); + if (procname >= 0 && (gp = glocate(procname)) != NULL) { + /* + * Initialize for wanted procedure. + */ + locinit(); + clearlab(); + lineno = 0; + implicit = gp->g_flag & F_ImpError; + nargs = gp->g_nargs; + align(); + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "\n# procedure %s\n", &lsspace[lsfree]); + #endif /* DeBugLinker */ + } + else { + /* + * Skip unreferenced procedure. + */ + while ((op = getopc(&name)) != EOF && op != Op_End) + if (op == Op_Filen) + setfile(); /* handle filename op while skipping */ + else + newline(); /* ignore everything else */ + } + break; + + case Op_Local: + k = getdec(); + flags = getoct(); + id = getid(); + putlocal(k, id, flags, implicit, procname); + break; + + case Op_Con: + k = getdec(); + flags = getoct(); + if (flags & F_IntLit) { + { + long m; + word s_indx; + + j = getdec(); /* number of characters in integer */ + m = getint(j,&s_indx); /* convert if possible */ + if (m < 0) { /* negative indicates integer too big */ + gg.sval = s_indx; /* convert to a string */ + putconst(k, F_StrLit, j, pc, &gg); + } + else { /* integers is small enough */ + gg.ival = m; + putconst(k, flags, 0, pc, &gg); + } + } + } + else if (flags & F_RealLit) { + gg.rval = getreal(); + putconst(k, flags, 0, pc, &gg); + } + else if (flags & F_StrLit) { + j = getdec(); + gg.sval = getstrlit(j); + putconst(k, flags, j, pc, &gg); + } + else if (flags & F_CsetLit) { + j = getdec(); + gg.sval = getstrlit(j); + putconst(k, flags, j, pc, &gg); + } + else + fprintf(stderr, "gencode: illegal constant\n"); + newline(); + lemitcon(k); + break; + + case Op_Filen: + setfile(); + break; + + case Op_Declend: + newline(); + gp->g_pc = pc; + lemitproc(procname, nargs, dynoff, lstatics-static1, static1); + break; + + case Op_End: + newline(); + flushcode(); + break; + + default: + fprintf(stderr, "gencode: illegal opcode(%d): %s\n", op, name); + newline(); + } + } + } + +/* + * setfile - handle Op_Filen. + */ +static void setfile() + { + if (fnmfree >= &fnmtbl[fnmsize]) + fnmtbl = (struct ipc_fname *) trealloc(fnmtbl, &fnmfree, + &fnmsize, sizeof(struct ipc_fname), 1, "file name table"); + fnmfree->ipc = pc; + fnmfree->fname = getrest(); + strcpy(icnname, &lsspace[fnmfree->fname]); + fnmfree++; + newline(); + } + +/* + * lemit - emit opcode. + * lemitl - emit opcode with reference to program label. + * for a description of the chaining and backpatching for labels. + * lemitn - emit opcode with integer argument. + * lemitr - emit opcode with pc-relative reference. + * lemitin - emit opcode with reference to identifier table & integer argument. + * lemitint - emit word opcode with integer argument. + * lemitcon - emit constant table entry. + * lemitproc - emit procedure block. + * + * The lemit* routines call out* routines to effect the "outputting" of icode. + * Note that the majority of the code for the lemit* routines is for debugging + * purposes. + */ +static void lemit(op, name) +int op; +char *name; + { + + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "%ld:\t%d\t\t\t\t# %s\n", (long)pc, op, name); + #endif /* DeBugLinker */ + + outop(op); + } + +static void lemitl(op, lab, name) +int op, lab; +char *name; + { + misalign(); + + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "%ld:\t%d\tL%d\t\t\t# %s\n", (long)pc, op, lab, name); + #endif /* DeBugLinker */ + + if (lab >= maxlabels) + labels = (word *) trealloc(labels, NULL, &maxlabels, sizeof(word), + lab - maxlabels + 1, "labels"); + outop(op); + if (labels[lab] <= 0) { /* forward reference */ + outword(labels[lab]); + labels[lab] = WordSize - pc; /* add to front of reference chain */ + } + else /* output relative offset */ + outword(labels[lab] - (pc + WordSize)); + } + +static void lemitn(op, n, name) +int op; +word n; +char *name; + { + misalign(); + + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "%ld:\t%d\t%ld\t\t\t# %s\n", (long)pc, op, (long)n, + name); + #endif /* DeBugLinker */ + + outop(op); + outword(n); + } + + +static void lemitr(op, loc, name) +int op; +word loc; +char *name; + { + misalign(); + + loc -= pc + ((IntBits/ByteBits) + WordSize); + + #ifdef DeBugLinker + if (Dflag) { + if (loc >= 0) + fprintf(dbgfile, "%ld:\t%d\t*+%ld\t\t\t# %s\n",(long) pc, op, + (long)loc, name); + else + fprintf(dbgfile, "%ld:\t%d\t*-%ld\t\t\t# %s\n",(long) pc, op, + (long)-loc, name); + } + #endif /* DeBugLinker */ + + outop(op); + outword(loc); + } + +static void lemitin(op, offset, n, name) +int op, n; +word offset; +char *name; + { + misalign(); + + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "%ld:\t%d\t%d,S+%ld\t\t\t# %s\n", (long)pc, op, n, + (long)offset, name); + #endif /* DeBugLinker */ + + outop(op); + outword(n); + outword(offset); + } + +/* + * lemitint can have some pitfalls. outword is used to output the + * integer and this is picked up in the interpreter as the second + * word of a short integer. The integer value output must be + * the same size as what the interpreter expects. See op_int and op_intx + * in interp.s + */ +static void lemitint(op, i, name) +int op; +long i; +char *name; + { + misalign(); + + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile,"%ld:\t%d\t%ld\t\t\t# %s\n",(long)pc,op,(long)i,name); + #endif /* DeBugLinker */ + + outop(op); + outword(i); + } + +static void lemitcon(k) +register int k; + { + register int i, j; + register char *s; + int csbuf[CsetSize]; + union { + char ovly[1]; /* Array used to overlay l and f on a bytewise basis. */ + long l; + double f; + } x; + + if (lctable[k].c_flag & F_RealLit) { + + #ifdef Double + /* access real values one word at a time */ + int *rp, *rq; + rp = (int *) &(x.f); + rq = (int *) &(lctable[k].c_val.rval); + *rp++ = *rq++; + *rp = *rq; + #else /* Double */ + x.f = lctable[k].c_val.rval; + #endif /* Double */ + + #ifdef DeBugLinker + if (Dflag) { + fprintf(dbgfile,"%ld:\t%d\t\t\t\t# real(%g)",(long)pc,T_Real, x.f); + dumpblock(x.ovly,sizeof(double)); + } + #endif /* DeBugLinker */ + + outword(T_Real); + + #ifdef Double + #if WordBits != 64 + /* fill out real block with an empty word */ + outword(0); + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile,"\t0\t\t\t\t\t# padding\n"); + #endif /* DeBugLinker */ + #endif /* WordBits != 64 */ + #endif /* Double */ + + outblock(x.ovly,sizeof(double)); + } + else if (lctable[k].c_flag & F_CsetLit) { + for (i = 0; i < CsetSize; i++) + csbuf[i] = 0; + s = &lsspace[lctable[k].c_val.sval]; + i = lctable[k].c_length; + while (i--) { + Setb(*s, csbuf); + s++; + } + j = 0; + for (i = 0; i < 256; i++) { + if (Testb(i, csbuf)) + j++; + } + + #ifdef DeBugLinker + if (Dflag) { + fprintf(dbgfile, "%ld:\t%d\n",(long) pc, T_Cset); + fprintf(dbgfile, "\t%d\n",j); + } + #endif /* DeBugLinker */ + + outword(T_Cset); + outword(j); /* cset size */ + outblock((char *)csbuf,sizeof(csbuf)); + + #ifdef DeBugLinker + if (Dflag) + dumpblock((char *)csbuf,CsetSize); + #endif /* DeBugLinker */ + + } + } + +static void lemitproc(name, nargs, ndyn, nstat, fstat) +word name; +int nargs, ndyn, nstat, fstat; + { + register int i; + register char *p; + word s_indx; + int size; + /* + * FncBlockSize = sizeof(BasicFncBlock) + + * sizeof(descrip)*(# of args + # of dynamics + # of statics). + */ + size = (9*WordSize) + (2*WordSize) * (abs(nargs)+ndyn+nstat); + + p = &lsspace[name]; + #ifdef DeBugLinker + if (Dflag) { + fprintf(dbgfile, "%ld:\t%d\n", (long)pc, T_Proc); /* type code */ + fprintf(dbgfile, "\t%d\n", size); /* size of block */ + fprintf(dbgfile, "\tZ+%ld\n",(long)(pc+size)); /* entry point */ + fprintf(dbgfile, "\t%d\n", nargs); /* # arguments */ + fprintf(dbgfile, "\t%d\n", ndyn); /* # dynamic locals */ + fprintf(dbgfile, "\t%d\n", nstat); /* # static locals */ + fprintf(dbgfile, "\t%d\n", fstat); /* first static */ + fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", /* name of procedure */ + (int)strlen(p), (long)(name), p); + } + #endif /* DeBugLinker */ + + outword(T_Proc); + outword(size); + outword(pc + size - 2*WordSize); /* Have to allow for the two words + that we've already output. */ + outword(nargs); + outword(ndyn); + outword(nstat); + outword(fstat); + outword(strlen(p)); /* procedure name: length & offset */ + outword(name); + + /* + * Output string descriptors for argument names by looping through + * all locals, and picking out those with F_Argument set. + */ + for (i = 0; i <= nlocal; i++) { + if (lltable[i].l_flag & F_Argument) { + s_indx = lltable[i].l_name; + p = &lsspace[s_indx]; + + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p), + (long)s_indx, p); + #endif /* DeBugLinker */ + + outword(strlen(p)); + outword(s_indx); + } + } + + /* + * Output string descriptors for local variable names. + */ + for (i = 0; i <= nlocal; i++) { + if (lltable[i].l_flag & F_Dynamic) { + s_indx = lltable[i].l_name; + p = &lsspace[s_indx]; + + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p), + (long)s_indx, p); + #endif /* DeBugLinker */ + + outword(strlen(p)); + outword(s_indx); + } + } + + /* + * Output string descriptors for static variable names. + */ + for (i = 0; i <= nlocal; i++) { + if (lltable[i].l_flag & F_Static) { + s_indx = lltable[i].l_name; + p = &lsspace[s_indx]; + + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(p), + (long)s_indx, p); + #endif /* DeBugLinker */ + + outword(strlen(p)); + outword(s_indx); + } + } + } + +/* + * gentables - generate interpreter code for global, static, + * identifier, and record tables, and built-in procedure blocks. + */ + +void gentables() + { + register int i; + register char *s; + register struct gentry *gp; + struct fentry *fp; + struct rentry *rp; + struct header hdr; + + /* + * Output record constructor procedure blocks. + */ + align(); + hdr.Records = pc; + + #ifdef DeBugLinker + if (Dflag) { + fprintf(dbgfile, "\n\n# global tables\n"); + fprintf(dbgfile, "\n%ld:\t%d\t\t\t\t# record blocks\n", + (long)pc, nrecords); + } + #endif /* DeBugLinker */ + + outword(nrecords); + for (gp = lgfirst; gp != NULL; gp = gp->g_next) { + if ((gp->g_flag & F_Record) && gp->g_procid > 0) { + s = &lsspace[gp->g_name]; + gp->g_pc = pc; + + #ifdef DeBugLinker + if (Dflag) { + fprintf(dbgfile, "%ld:\n", pc); + fprintf(dbgfile, "\t%d\n", T_Proc); + fprintf(dbgfile, "\t%d\n", RkBlkSize(gp)); + fprintf(dbgfile, "\t_mkrec\n"); + fprintf(dbgfile, "\t%d\n", gp->g_nargs); + fprintf(dbgfile, "\t-2\n"); + fprintf(dbgfile, "\t%d\n", gp->g_procid); + fprintf(dbgfile, "\t1\n"); + fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", (int)strlen(s), + (long)gp->g_name, s); + } + #endif /* DeBugLinker */ + + outword(T_Proc); /* type code */ + outword(RkBlkSize(gp)); + outword(0); /* entry point (filled in by interp)*/ + outword(gp->g_nargs); /* number of fields */ + outword(-2); /* record constructor indicator */ + outword(gp->g_procid); /* record id */ + outword(1); /* serial number */ + outword(strlen(s)); /* name of record: size and offset */ + outword(gp->g_name); + + for (i=0;ig_nargs;i++) { /* field names (filled in by interp) */ + int foundit = 0; + /* + * Find the field list entry corresponding to field i in + * record gp, then write out a descriptor for it. + */ + for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) { + for (rp = fp->f_rlist; rp!= NULL; rp=rp->r_link) { + if (rp->r_gp == gp && rp->r_fnum == i) { + if (foundit) { + /* + * This internal error should never occur + */ + fprintf(stderr,"found rec %d field %d already!!\n", + gp->g_procid, i); + fflush(stderr); + exit(1); + } + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "\t%d\tS+%ld\t\t\t# %s\n", + (int)strlen(&lsspace[fp->f_name]), + fp->f_name, &lsspace[fp->f_name]); + #endif /* DeBugLinker */ + outword(strlen(&lsspace[fp->f_name])); + outword(fp->f_name); + foundit++; + } + } + } + if (!foundit) { + /* + * This internal error should never occur + */ + fprintf(stderr,"never found rec %d field %d!!\n", + gp->g_procid,i); + fflush(stderr); + exit(1); + } + } + } + } + + #ifndef FieldTableCompression + + /* + * Output record/field table (not compressed). + */ + hdr.Ftab = pc; + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile,"\n%ld:\t\t\t\t\t# record/field table\n",(long)pc); + #endif /* DeBugLinker */ + + for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) { + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "%ld:\t\t\t\t\t# %s\n", (long)pc, + &lsspace[fp->f_name]); + #endif /* DeBugLinker */ + rp = fp->f_rlist; + for (i = 1; i <= nrecords; i++) { + while (rp != NULL && rp->r_gp->g_procid < 0) + rp = rp->r_link; /* skip unreferenced constructor */ + if (rp != NULL && rp->r_gp->g_procid == i) { + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "\t%d\n", rp->r_fnum); + #endif /* DeBugLinker */ + outop(rp->r_fnum); + rp = rp->r_link; + } + else { + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "\t-1\n"); + #endif /* DeBugLinker */ + outop(-1); + } + #ifdef DeBugLinker + if (Dflag && (i == nrecords || (i & 03) == 0)) + putc('\n', dbgfile); + #endif /* DeBugLinker */ + } + } + + #else /* FieldTableCompression */ + + /* + * Output record/field table (compressed). + * This code has not been tested recently. + */ + { + int counter = 0, f_num, first, begin, end, entries; + int *f_fo, *f_row, *f_tabp; + char *f_bm; + int pointer, first_avail = 0, inserted, bytes; + hdr.Fo = pc; + + /* + * Compute the field width required for this binary; + * it is determined by the maximum # of fields in any one record. + */ + long ct = 0; + for (gp = lgfirst; gp != NULL; gp = gp->g_next) + if ((gp->g_flag & F_Record) && gp->g_procid > 0) + if (gp->g_nargs > ct) ct=gp->g_nargs; + if (ct > 65535L) hdr.FtabWidth = 4; + else if (ct > 254) hdr.FtabWidth = 2; /* 255 is (not present) */ + else hdr.FtabWidth = 1; + + /* Find out how many field names there are. */ + hdr.Nfields = 0; + for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) + hdr.Nfields++; + + entries = hdr.Nfields * nrecords / 4 + 1; + f_tabp = malloc (entries * sizeof (int)); + for (i = 0; i < entries; i++) + f_tabp[i] = -1; + f_fo = malloc (hdr.Nfields * sizeof (int)); + + bytes = nrecords / 8; + if (nrecords % 8 != 0) + bytes++; + f_bm = calloc (hdr.Nfields, bytes); + f_row = malloc (nrecords * sizeof (int)); + f_num = 0; + + for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) { + rp = fp->f_rlist; + first = 1; + for (i = 0; i < nrecords; i++) { + while (rp != NULL && rp->r_gp->g_procid < 0) + rp = rp->r_link; /* skip unreferenced constructor */ + if (rp != NULL && rp->r_gp->g_procid == i + 1) { + if (first) { + first = 0; + begin = end = i; + } + else + end = i; + f_row[i] = rp->r_fnum; + rp = rp->r_link; + } + else { + f_row[i] = -1; + } + } + + inserted = 0; + pointer = first_avail; + while (!inserted) { + inserted = 1; + for (i = begin; i <= end; i++) { + if (pointer + (end - begin) >= entries) { + int j; + int old_entries = entries; + entries *= 2; + f_tabp = realloc (f_tabp, entries * sizeof (int)); + for (j = old_entries; j < entries; j++) + f_tabp[j] = -1; + } + if (f_row[i] != -1) + if (f_tabp[pointer + (i - begin)] != -1) { + inserted = 0; + break; + } + } + pointer++; + } + pointer--; + + /* Create bitmap */ + for (i = 0; i < nrecords; i++) { + int index = f_num * bytes + i / 8; + /* Picks out byte within bitmap row */ + if (f_row[i] != -1) { + f_bm[index] |= 01; + } + if (i % 8 != 7) + f_bm [index] <<= 1; + } + + if (nrecords%8) + f_bm[(f_num + 1) * bytes - 1] <<= 7 - (nrecords % 8); + + f_fo[f_num++] = pointer - begin; + /* So that f_fo[] points to the first bit */ + + for (i = begin; i <= end; i++) + if (f_row[i] != -1) + f_tabp[pointer + (i - begin)] = f_row[i]; + if (pointer + (end - begin) >= counter) + counter = pointer + (end - begin + 1); + while ((f_tabp[first_avail] != -1) && (first_avail <= counter)) + first_avail++; + } + + /* Write out the arrays. */ + #ifdef DeBugLinker + if (Dflag) + fprintf (dbgfile, "\n%ld:\t\t\t\t\t# field offset array\n", + (long)pc); + #endif /* DeBugLinker */ + + /* + * Compute largest value stored in fo array + */ + { + word maxfo = 0; + for (i = 0; i < hdr.Nfields; i++) { + if (f_fo[i] > maxfo) maxfo = f_fo[i]; + } + if (maxfo < 254) + hdr.FoffWidth = 1; + else if (maxfo < 65535L) + hdr.FoffWidth = 2; + else + hdr.FoffWidth = 4; + } + + for (i = 0; i < hdr.Nfields; i++) { + #ifdef DeBugLinker + if (Dflag) + fprintf (dbgfile, "\t%d\n", f_fo[i]); + #endif /* DeBugLinker */ + if (hdr.FoffWidth == 1) { + outchar(f_fo[i]); + } + else if (hdr.FoffWidth == 2) + outshort(f_fo[i]); + else + outop (f_fo[i]); + } + + #ifdef DeBugLinker + if (Dflag) + fprintf (dbgfile, "\n%ld:\t\t\t\t\t# Bit maps array\n", + (long)pc); + #endif /* DeBugLinker */ + + for (i = 0; i < hdr.Nfields; i++) { + #ifdef DeBugLinker + if (Dflag) { + int ct, index = i * bytes; + unsigned char this_bit = 0200; + + fprintf (dbgfile, "\t"); + for (ct = 0; ct < nrecords; ct++) { + if ((f_bm[index] | this_bit) == f_bm[index]) + fprintf (dbgfile, "1"); + else + fprintf (dbgfile, "0"); + + if (ct % 8 == 7) { + fprintf (dbgfile, " "); + index++; + this_bit = 0200; + } + else + this_bit >>= 1; + } + fprintf (dbgfile, "\n"); + } + #endif /* DeBugLinker */ + for (pointer = i * bytes; pointer < (i + 1) * bytes; pointer++) { + outchar (f_bm[pointer]); + } + } + + align(); + + #ifdef DeBugLinker + if (Dflag) + fprintf (dbgfile, "\n%ld:\t\t\t\t\t# record/field array\n", + (long)pc); + #endif /* DeBugLinker */ + + hdr.Ftab = pc; + for (i = 0; i < counter; i++) { + #ifdef DeBugLinker + if (Dflag) + fprintf (dbgfile, "\t%d\t%d\n", i, f_tabp[i]); + #endif /* DeBugLinker */ + if (hdr.FtabWidth == 1) + outchar(f_tabp[i]); + else if (hdr.FtabWidth == 2) + outshort(f_tabp[i]); + else + outop (f_tabp[i]); + } + + /* Free memory allocated by Jigsaw. */ + free (f_fo); + free (f_bm); + free (f_tabp); + free (f_row); + } + + #endif /* FieldTableCompression */ + + /* + * Output descriptors for field names. + */ + align(); + hdr.Fnames = pc; + for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) { + s = &lsspace[fp->f_name]; + + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "%ld:\t%d\tS+%ld\t\t\t# %s\n", + (long)pc, (int)strlen(s), (long)fp->f_name, s); + #endif /* DeBugLinker */ + + outword(strlen(s)); /* name of field: length & offset */ + outword(fp->f_name); + } + + /* + * Output global variable descriptors. + */ + hdr.Globals = pc; + for (gp = lgfirst; gp != NULL; gp = gp->g_next) { + if (gp->g_flag & F_Builtin) { /* function */ + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "%ld:\t%06lo\t%d\t\t\t# %s\n", + (long)pc, (long)D_Proc, -gp->g_procid, &lsspace[gp->g_name]); + #endif /* DeBugLinker */ + outword(D_Proc); + outword(-gp->g_procid); + } + else if (gp->g_flag & F_Proc) { /* Icon procedure */ + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n", + (long)pc,(long)D_Proc, (long)gp->g_pc, &lsspace[gp->g_name]); + #endif /* DeBugLinker */ + outword(D_Proc); + outword(gp->g_pc); + } + else if (gp->g_flag & F_Record) { /* record constructor */ + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "%ld:\t%06lo\tZ+%ld\t\t\t# %s\n", (long) pc, + (long)D_Proc, (long)gp->g_pc, &lsspace[gp->g_name]); + #endif /* DeBugLinker */ + outword(D_Proc); + outword(gp->g_pc); + } + else { /* simple global variable */ + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "%ld:\t%06lo\t0\t\t\t# %s\n",(long)pc, + (long)D_Null, &lsspace[gp->g_name]); + #endif /* DeBugLinker */ + outword(D_Null); + outword(0); + } + } + + /* + * Output descriptors for global variable names. + */ + hdr.Gnames = pc; + for (gp = lgfirst; gp != NULL; gp = gp->g_next) { + + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "%ld:\t%d\tS+%ld\t\t\t# %s\n", + (long)pc, (int)strlen(&lsspace[gp->g_name]), (long)(gp->g_name), + &lsspace[gp->g_name]); + #endif /* DeBugLinker */ + + outword(strlen(&lsspace[gp->g_name])); + outword(gp->g_name); + } + + /* + * Output a null descriptor for each static variable. + */ + hdr.Statics = pc; + for (i = lstatics; i > 0; i--) { + + #ifdef DeBugLinker + if (Dflag) + fprintf(dbgfile, "%ld:\t0\t0\n", (long)pc); + #endif /* DeBugLinker */ + + outword(D_Null); + outword(0); + } + flushcode(); + + /* + * Output the string constant table and the two tables associating icode + * locations with source program locations. Note that the calls to write + * really do all the work. + */ + + hdr.Filenms = pc; + if (longwrite((char *)fnmtbl, (long)((char *)fnmfree - (char *)fnmtbl), + outfile) < 0) + quit("cannot write icode file"); + + #ifdef DeBugLinker + if (Dflag) { + int k = 0; + struct ipc_fname *ptr; + for (ptr = fnmtbl; ptr < fnmfree; ptr++) { + fprintf(dbgfile, "%ld:\t%03d\tS+%03d\t\t\t# %s\n", + (long)(pc + k), ptr->ipc, ptr->fname, &lsspace[ptr->fname]); + k = k + 8; + } + putc('\n', dbgfile); + } + + #endif /* DeBugLinker */ + + pc += (char *)fnmfree - (char *)fnmtbl; + + hdr.linenums = pc; + if (longwrite((char *)lntable, (long)((char *)lnfree - (char *)lntable), + outfile) < 0) + quit("cannot write icode file"); + + #ifdef DeBugLinker + if (Dflag) { + int k = 0; + struct ipc_line *ptr; + for (ptr = lntable; ptr < lnfree; ptr++) { + fprintf(dbgfile, "%ld:\t%03d\t%03d\n", (long)(pc + k), + ptr->ipc, ptr->line); + k = k + 8; + } + putc('\n', dbgfile); + } + + #endif /* DeBugLinker */ + + pc += (char *)lnfree - (char *)lntable; + + hdr.Strcons = pc; + #ifdef DeBugLinker + if (Dflag) { + int c, j, k; + j = k = 0; + for (s = lsspace; s < &lsspace[lsfree]; ) { + fprintf(dbgfile, "%ld:\t%03o", (long)(pc + k), *s++ & 0377); + k = k + 8; + for (i = 7; i > 0; i--) { + if (s >= &lsspace[lsfree]) + fprintf(dbgfile," "); + else + fprintf(dbgfile, " %03o", *s++ & 0377); + } + fprintf(dbgfile, " "); + for (i = 0; i < 8; i++) + if (j < lsfree) { + c = lsspace[j++]; + putc(isprint(c & 0377) ? c : ' ', dbgfile); + } + putc('\n', dbgfile); + } + } + + #endif /* DeBugLinker */ + + if (longwrite(lsspace, (long)lsfree, outfile) < 0) + quit("cannot write icode file"); + + pc += lsfree; + + /* + * Output icode file header. + */ + hdr.hsize = pc; + strcpy((char *)hdr.config,IVersion); + hdr.trace = trace; + + + #ifdef DeBugLinker + if (Dflag) { + fprintf(dbgfile, "\n"); + fprintf(dbgfile, "size: %ld\n", (long)hdr.hsize); + fprintf(dbgfile, "trace: %ld\n", (long)hdr.trace); + fprintf(dbgfile, "records: %ld\n", (long)hdr.Records); + fprintf(dbgfile, "ftab: %ld\n", (long)hdr.Ftab); + fprintf(dbgfile, "fnames: %ld\n", (long)hdr.Fnames); + fprintf(dbgfile, "globals: %ld\n", (long)hdr.Globals); + fprintf(dbgfile, "gnames: %ld\n", (long)hdr.Gnames); + fprintf(dbgfile, "statics: %ld\n", (long)hdr.Statics); + fprintf(dbgfile, "strcons: %ld\n", (long)hdr.Strcons); + fprintf(dbgfile, "filenms: %ld\n", (long)hdr.Filenms); + fprintf(dbgfile, "linenums: %ld\n", (long)hdr.linenums); + fprintf(dbgfile, "config: %s\n", hdr.config); + } + #endif /* DeBugLinker */ + + fseek(outfile, hdrsize, 0); + if (longwrite((char *)&hdr, (long)sizeof(hdr), outfile) < 0) + quit("cannot write icode file"); + + if (verbose >= 2) { + word tsize = sizeof(hdr) + hdr.hsize; + fprintf(stderr, " bootstrap %7ld\n", hdrsize); + tsize += hdrsize; + fprintf(stderr, " header %7ld\n", (long)sizeof(hdr)); + fprintf(stderr, " procedures %7ld\n", (long)hdr.Records); + fprintf(stderr, " records %7ld\n", (long)(hdr.Ftab - hdr.Records)); + fprintf(stderr, " fields %7ld\n", (long)(hdr.Globals - hdr.Ftab)); + fprintf(stderr, " globals %7ld\n", (long)(hdr.Statics - hdr.Globals)); + fprintf(stderr, " statics %7ld\n", (long)(hdr.Filenms - hdr.Statics)); + fprintf(stderr, " linenums %7ld\n", (long)(hdr.Strcons - hdr.Filenms)); + fprintf(stderr, " strings %7ld\n", (long)(hdr.hsize - hdr.Strcons)); + fprintf(stderr, " total %7ld\n", (long)tsize); + } + } + +/* + * align() outputs zeroes as padding until pc is a multiple of WordSize. + */ +static void align() + { + static word x = 0; + + if (pc % WordSize != 0) + outblock((char *)&x, (int)(WordSize - (pc % WordSize))); + } + +/* + * misalign() outputs a Noop instruction for padding if pc + sizeof(int) + * is not a multiple of WordSize. This is for operations that output + * an int opcode followed by an operand that needs to be word-aligned. + */ +static void misalign() + { + if ((pc + IntBits/ByteBits) % WordSize != 0) + lemit(Op_Noop, "noop [pad]"); + } + +/* + * intout(i) outputs i as an int that is used by the runtime system + * IntBits/ByteBits bytes must be moved from &word[0] to &codep[0]. + */ +static void intout(oint) +int oint; + { + int i; + union { + int i; + char c[IntBits/ByteBits]; + } u; + + CodeCheck(IntBits/ByteBits); + u.i = oint; + + for (i = 0; i < IntBits/ByteBits; i++) + codep[i] = u.c[i]; + + codep += IntBits/ByteBits; + pc += IntBits/ByteBits; + } + +#ifdef FieldTableCompression +/* + * charout(i) outputs i as an unsigned char that is used by the runtime system + */ +static void charout(unsigned char ochar) + { + CodeCheck(1); + *codep++ = (unsigned char)ochar; + pc++; + } +/* + * shortout(i) outputs i as a short that is used by the runtime system + * IntBits/ByteBits bytes must be moved from &word[0] to &codep[0]. + */ +static void shortout(short oint) + { + int i; + union { + short i; + char c[2]; + } u; + + CodeCheck(2); + u.i = oint; + + for (i = 0; i < 2; i++) + codep[i] = u.c[i]; + + codep += 2; + pc += 2; + } +#endif /* FieldTableCompression */ + + +/* + * wordout(i) outputs i as a word that is used by the runtime system + * WordSize bytes must be moved from &oword[0] to &codep[0]. + */ +static void wordout(oword) +word oword; + { + int i; + union { + word i; + char c[WordSize]; + } u; + + CodeCheck(WordSize); + u.i = oword; + + for (i = 0; i < WordSize; i++) + codep[i] = u.c[i]; + + codep += WordSize; + pc += WordSize; + } + +/* + * outblock(a,i) output i bytes starting at address a. + */ +static void outblock(addr,count) +char *addr; +int count; + { + CodeCheck(count); + pc += count; + while (count--) + *codep++ = *addr++; + } + +#ifdef DeBugLinker + /* + * dumpblock(a,i) dump contents of i bytes at address a, used only + * in conjunction with -L. + */ + static void dumpblock(addr, count) + char *addr; + int count; + { + int i; + for (i = 0; i < count; i++) { + if ((i & 7) == 0) + fprintf(dbgfile,"\n\t"); + fprintf(dbgfile," %03o",(0377 & (unsigned)addr[i])); + } + putc('\n',dbgfile); + } + #endif /* DeBugLinker */ + +/* + * flushcode - write buffered code to the output file. + */ +static void flushcode() + { + if (codep > codeb) + if (longwrite(codeb, DiffPtrs(codep,codeb), outfile) < 0) + quit("cannot write icode file"); + codep = codeb; + } + +/* + * clearlab - clear label table to all zeroes. + */ +static void clearlab() + { + register int i; + + for (i = 0; i < maxlabels; i++) + labels[i] = 0; + } + +/* + * backpatch - fill in all forward references to lab. + */ +static void backpatch(lab) +int lab; + { + word p, r; + char *q; + char *cp, *cr; + register int j; + + if (lab >= maxlabels) + labels = (word *) trealloc(labels, NULL, &maxlabels, sizeof(word), + lab - maxlabels + 1, "labels"); + + p = labels[lab]; + if (p > 0) + quit("multiply defined label in ucode"); + while (p < 0) { /* follow reference chain */ + r = pc - (WordSize - p); /* compute relative offset */ + q = codep - (pc + p); /* point to word with address */ + cp = (char *) &p; /* address of integer p */ + cr = (char *) &r; /* address of integer r */ + for (j = 0; j < WordSize; j++) { /* move bytes from word pointed to */ + *cp++ = *q; /* by q to p, and move bytes from */ + *q++ = *cr++; /* r to word pointed to by q */ + } /* moves integers at arbitrary addresses */ + } + labels[lab] = pc; + } + +#ifdef DeBugLinker + void idump(s) /* dump code region */ + char *s; + { + int *c; + + fprintf(stderr,"\ndump of code region %s:\n",s); + for (c = (int *)codeb; c < (int *)codep; c++) + fprintf(stderr,"%ld: %d\n",(long)c, (int)*c); + fflush(stderr); + } + #endif /* DeBugLinker */ diff --git a/src/icont/lfile.h b/src/icont/lfile.h new file mode 100644 index 0000000..1da9746 --- /dev/null +++ b/src/icont/lfile.h @@ -0,0 +1,21 @@ +/* + * A linked list of files named by link declarations is maintained using + * lfile structures. + */ +struct lfile { + char *lf_name; /* name of the file */ + struct lfile *lf_link; /* pointer to next file */ + }; + +extern struct lfile *lfiles; + + +/* + * "Invocable" declarations are recorded in a list of invkl structs. + */ +struct invkl { + char *iv_name; /* name of global */ + struct invkl *iv_link; /* link to next entry */ + }; + +extern struct invkl *invkls; diff --git a/src/icont/lglob.c b/src/icont/lglob.c new file mode 100644 index 0000000..6583b8a --- /dev/null +++ b/src/icont/lglob.c @@ -0,0 +1,356 @@ +/* + * lglob.c -- routines for processing globals. + */ + +#include "link.h" +#include "tglobals.h" +#include "tproto.h" +#include "opcode.h" +#include "../h/version.h" + +/* + * Prototypes. + */ + +static void scanfile (char *filename); +static void reference (struct gentry *gp); + +int nrecords = 0; /* number of records in program */ + +/* + * readglob reads the global information from infile (.u2) and merges it with + * the global table and record table. + */ +void readglob() + { + register word id; + register int n, op; + int k; + int implicit; + char *name; + struct gentry *gp; + extern char *progname; + + if (getopc(&name) != Op_Version) + quitf("ucode file %s has no version identification",inname); + id = getid(); /* get version number of ucode */ + newline(); + if (strcmp(&lsspace[id],UVersion)) { + fprintf(stderr,"version mismatch in ucode file %s\n",inname); + fprintf(stderr,"\tucode version: %s\n",&lsspace[id]); + fprintf(stderr,"\texpected version: %s\n",UVersion); + exit(EXIT_FAILURE); + } + while ((op = getopc(&name)) != EOF) { + switch (op) { + case Op_Record: /* a record declaration */ + id = getid(); /* record name */ + n = getdec(); /* number of fields */ + newline(); + gp = glocate(id); + /* + * It's ok if the name isn't already in use or if the + * name is just used in a "global" declaration. Otherwise, + * it is an inconsistent redeclaration. + */ + if (gp == NULL || (gp->g_flag & ~F_Global) == 0) { + gp = putglobal(id, F_Record, n, ++nrecords); + while (n--) { /* loop reading field numbers and names */ + k = getdec(); + putfield(getid(), gp, k); + newline(); + } + } + else { + lfatal(&lsspace[id], "inconsistent redeclaration"); + while (n--) + newline(); + } + break; + + case Op_Impl: /* undeclared identifiers should be noted */ + if (getopc(&name) == Op_Local) + implicit = 0; + else + implicit = F_ImpError; + break; + + case Op_Trace: /* turn on tracing */ + trace = -1; + break; + + case Op_Global: /* global variable declarations */ + n = getdec(); /* number of global declarations */ + newline(); + while (n--) { /* process each declaration */ + getdec(); /* throw away sequence number */ + k = getoct(); /* get flags */ + if (k & F_Proc) + k |= implicit; + id = getid(); /* get variable name */ + gp = glocate(id); + /* + * Check for conflicting declarations and install the + * variable. + */ + if (gp != NULL && (k & F_Proc) && gp->g_flag != F_Global) + lfatal(&lsspace[id], "inconsistent redeclaration"); + else if (gp == NULL || (k & F_Proc)) + putglobal(id, k, getdec(), 0); + newline(); + } + break; + + case Op_Invocable: /* "invocable" declaration */ + id = getid(); /* get name */ + if (lsspace[id] == '0') + strinv = 1; /* name of "0" means "invocable all" */ + else + addinvk(&lsspace[id], 2); + newline(); + break; + + case Op_Link: /* link the named file */ + name = &lsspace[getrest()]; /* get the name and */ + alsolink(name); /* put it on the list of files to link */ + newline(); + break; + + default: + quitf("ill-formed global file %s",inname); + } + } + } + +/* + * scanrefs - scan .u1 files for references and mark unreferenced globals. + * + * Called only if -fs is *not* specified (or implied by "invocable all"). + */ +void scanrefs() + { + int i, n; + char *t, *old; + struct fentry *fp, **fpp; + struct gentry *gp, **gpp; + struct rentry *rp; + struct lfile *lf, *lfls; + struct ientry *ip, *ipnext; + struct invkl *inv; + + /* + * Loop through .u1 files and accumulate reference lists. + */ + lfls = llfiles; + while ((lf = getlfile(&lfls)) != 0) + scanfile(lf->lf_name); + lstatics = 0; /* discard accumulated statics */ + + /* + * Mark every global as unreferenced. + */ + for (gp = lgfirst; gp != NULL; gp = gp->g_next) + gp->g_flag |= F_Unref; + + /* + * Clear the F_Unref flag for referenced globals, starting with main() + * and marking references within procedures recursively. + */ + reference(lgfirst); + + /* + * Reference (recursively) every global declared to be "invocable". + */ + for (inv = invkls; inv != NULL; inv = inv->iv_link) + if ((gp = glocate(instid(inv->iv_name))) != NULL) + reference(gp); + + /* + * Rebuild the global list to include only referenced globals, + * and renumber them. Also renumber all record constructors. + * Free all reference lists. + */ + n = 0; + nrecords = 0; + gpp = &lgfirst; + while ((gp = *gpp) != NULL) { + if (gp->g_refs != NULL) { + free((char *)gp->g_refs); /* free the reference list */ + gp->g_refs = NULL; + } + if (gp->g_flag & F_Unref) { + /* + * Global is not referenced anywhere. + */ + gp->g_index = gp->g_procid = -1; /* flag as unused */ + if (verbose >= 3) { + if (gp->g_flag & F_Proc) + t = "procedure"; + else if (gp->g_flag & F_Record) + t = "record "; + else + t = "global "; + if (!(gp->g_flag & F_Builtin)) + fprintf(stderr, " discarding %s %s\n", t, &lsspace[gp->g_name]); + } + *gpp = gp->g_next; + } + else { + /* + * The global is used. Assign it new serial number(s). + */ + gp->g_index = n++; + if (gp->g_flag & F_Record) + gp->g_procid = ++nrecords; + gpp = &gp->g_next; + } + } + + /* + * Rebuild the field list to include only referenced fields, + * and renumber them. + */ + n = 0; + fpp = &lffirst; + while ((fp = *fpp) != NULL) { + for (rp = fp->f_rlist; rp != NULL; rp = rp->r_link) + if (rp->r_gp->g_procid > 0) /* if record was referenced */ + break; + if (rp == NULL) { + /* + * The field was used only in unreferenced record constructors. + */ + fp->f_fid = 0; + *fpp = fp->f_nextentry; + } + else { + /* + * The field was referenced. Give it the next number. + */ + fp->f_fid = ++n; + fpp = &fp->f_nextentry; + } + } + + /* + * Create a new, empty string space, saving a pointer to the old one. + * Clear the old identifier hash table. + */ + old = lsspace; + lsspace = (char *)tcalloc(stsize, 1); + lsfree = 0; + for (i = 0; i < ihsize; i++) { + for (ip = lihash[i]; ip != NULL; ip = ipnext) { + ipnext = ip->i_blink; + free((char *)ip); + } + lihash[i] = NULL; + } + + /* + * Reinstall the global identifiers that are actually referenced. + * This changes the hashing, so clear and rebuild the hash table. + */ + for (i = 0; i < ghsize; i++) + lghash[i] = NULL; + for (gp = lgfirst; gp != NULL; gp = gp->g_next) { + gp->g_name = instid(&old[gp->g_name]); + i = ghasher(gp->g_name); + gp->g_blink = lghash[i]; + lghash[i] = gp; + } + + /* + * Reinstall the referenced record fields in similar fashion. + */ + for (i = 0; i < fhsize; i++) + lfhash[i] = NULL; + for (fp = lffirst; fp != NULL; fp = fp->f_nextentry) { + fp->f_name = instid(&old[fp->f_name]); + i = fhasher(fp->f_name); + fp->f_blink = lfhash[i]; + lfhash[i] = fp; + } + + /* + * Free the old string space. + */ + free((char *)old); + } + +/* + * scanfile -- scan one file for references. + */ +static void scanfile(filename) +char *filename; + { + int i, k, f, op, nrefs, flags; + word id, procid; + char *name; + struct gentry *gp, **rp; + + makename(inname, SourceDir, filename, U1Suffix); + infile = fopen(inname, "r"); + if (infile == NULL) + quitf("cannot open %s", inname); + + while ((op = getopc(&name)) != EOF) { + switch (op) { + case Op_Proc: + procid = getid(); + newline(); + gp = glocate(procid); + locinit(); + nrefs = 0; + break; + case Op_Local: + k = getdec(); + flags = getoct(); + id = getid(); + putlocal(k, id, flags, 0, procid); + lltable[k].l_flag |= F_Unref; + break; + case Op_Var: + k = getdec(); + newline(); + f = lltable[k].l_flag; + if ((f & F_Global) && (f & F_Unref)) { + lltable[k].l_flag = f & ~F_Unref; + nrefs++; + } + break; + case Op_End: + newline(); + if (nrefs > 0) { + rp = (struct gentry **)tcalloc(nrefs + 1, sizeof(*rp)); + gp->g_refs = rp; + for (i = 0; i <= nlocal; i++) + if ((lltable[i].l_flag & (F_Unref + F_Global)) == F_Global) + *rp++ = lltable[i].l_val.global; + *rp = NULL; + } + break; + default: + newline(); + break; + } + } + + fclose(infile); + } + +/* + * + */ +static void reference(gp) +struct gentry *gp; + { + struct gentry **rp; + + if (gp->g_flag & F_Unref) { + gp->g_flag &= ~F_Unref; + if ((rp = gp->g_refs) != NULL) + while ((gp = *rp++) != 0) + reference(gp); + } + } diff --git a/src/icont/link.c b/src/icont/link.c new file mode 100644 index 0000000..362b257 --- /dev/null +++ b/src/icont/link.c @@ -0,0 +1,228 @@ +/* + * link.c -- linker main program that controls the linking process. + */ + +#include "link.h" +#include "tproto.h" +#include "tglobals.h" +#include "../h/header.h" + +#include +#include + +#ifdef BinaryHeader + #include "hdr.h" +#endif /* BinaryHeader */ + +static void setexe (char *fname); + +FILE *infile; /* input file (.u1 or .u2) */ +FILE *outfile; /* interpreter code output file */ + +#ifdef DeBugLinker + FILE *dbgfile; /* debug file */ + static char dbgname[MaxPath]; /* debug file name */ +#endif /* DeBugLinker */ + +struct lfile *llfiles = NULL; /* List of files to link */ + +char inname[MaxPath]; /* input file name */ + +char icnname[MaxPath]; /* current icon source file name */ +int colmno = 0; /* current source column number */ +int lineno = 0; /* current source line number */ +int fatals = 0; /* number of errors encountered */ + +/* + * ilink - link a number of files, returning error count + */ +int ilink(ifiles,outname) +char **ifiles; +char *outname; + { + int i; + struct lfile *lf,*lfls; + char *filename; /* name of current input file */ + + linit(); /* initialize memory structures */ + while (*ifiles) + alsolink(*ifiles++); /* make initial list of files */ + + /* + * Phase I: load global information contained in .u2 files into + * data structures. + * + * The list of files to link is maintained as a queue with llfiles + * as the base. lf moves along the list. Each file is processed + * in turn by forming .u2 and .icn names from each file name, each + * of which ends in .u1. The .u2 file is opened and globals is called + * to process it. When the end of the list is reached, lf becomes + * NULL and the loop is terminated, completing phase I. Note that + * link instructions in the .u2 file cause files to be added to list + * of files to link. + */ + for (lf = llfiles; lf != NULL; lf = lf->lf_link) { + filename = lf->lf_name; + makename(inname, SourceDir, filename, U2Suffix); + makename(icnname, TargetDir, filename, SourceSuffix); + infile = fopen(inname, "r"); + if (infile == NULL) + quitf("cannot open %s",inname); + readglob(); + fclose(infile); + } + + /* Phase II (optional): scan code and suppress unreferenced procs. */ + if (!strinv) + scanrefs(); + + /* Phase III: resolve undeclared variables and generate code. */ + + /* + * Open the output file. + */ + outfile = fopen(outname, "wb"); + + if (outfile == NULL) { /* may exist, but can't open for "w" */ + ofile = NULL; /* so don't delete if it's there */ + quitf("cannot create %s",outname); + } + + /* + * Write the bootstrap header to the output file. + */ + #ifdef BinaryHeader + /* + * With BinaryHeader defined, always write MaxHdr bytes. + */ + fwrite(iconxhdr, sizeof(char), MaxHdr, outfile); + hdrsize = MaxHdr; + + #else /* BinaryHeader */ + /* + * Write a short shell header terminated by \n\f\n\0. + * Use magic "#!/bin/sh" to ensure that $0 is set when run via $PATH. + * Pad header to a multiple of 8 characters. + * + * The shell header searches for iconx in this order: + * a. location specified by ICONX environment variable + * (if specified, this MUST work, else the script exits) + * b. iconx in same directory as executing binary + * c. location specified in script + * (as generated by icont or as patched later) + * d. iconx in $PATH + * + * The ugly ${1+"$@"} is a workaround for non-POSIX handling + * of "$@" by some shells in the absence of any arguments. + * Thanks to the Unix-haters handbook for this trick. + */ + { + char script[2 * MaxPath + 300]; + sprintf(script, "%s\n%s%-72s\n%s\n\n%s\n%s\n%s\n%s\n\n%s\n", + "#!/bin/sh", + "IXBIN=", iconxloc, + "IXLCL=`echo $0 | sed 's=[^/]*$=iconx='`", + "[ -n \"$ICONX\" ] && exec \"$ICONX\" $0 ${1+\"$@\"}", + "[ -x \"$IXLCL\" ] && exec \"$IXLCL\" $0 ${1+\"$@\"}", + "[ -x \"$IXBIN\" ] && exec \"$IXBIN\" $0 ${1+\"$@\"}", + "exec iconx $0 ${1+\"$@\"}", + "[executable Icon binary follows]"); + strcat(script, " \n\f\n" + ((int)(strlen(script) + 4) % 8)); + hdrsize = strlen(script) + 1; /* length includes \0 at end */ + fwrite(script, hdrsize, 1, outfile); /* write header */ + } + + #endif /* BinaryHeader */ + + for (i = sizeof(struct header); i--;) + putc(0, outfile); + fflush(outfile); + if (ferror(outfile) != 0) + quit("unable to write to icode file"); + + #ifdef DeBugLinker + /* + * Open the .ux file if debugging is on. + */ + if (Dflag) { + makename(dbgname, TargetDir, llfiles->lf_name, ".ux"); + dbgfile = fopen(dbgname, "w"); + if (dbgfile == NULL) + quitf("cannot create %s", dbgname); + } + #endif /* DeBugLinker */ + + /* + * Loop through input files and generate code for each. + */ + lfls = llfiles; + while ((lf = getlfile(&lfls)) != 0) { + filename = lf->lf_name; + makename(inname, SourceDir, filename, U1Suffix); + makename(icnname, TargetDir, filename, SourceSuffix); + infile = fopen(inname, "r"); + if (infile == NULL) + quitf("cannot open %s", inname); + gencode(); + fclose(infile); + } + + gentables(); /* Generate record, field, global, global names, + static, and identifier tables. */ + + fclose(outfile); + lmfree(); + if (fatals > 0) + return fatals; + setexe(outname); + return 0; + } + +/* + * lwarn - issue a linker warning message. + */ +void lwarn(s1, s2, s3) +char *s1, *s2, *s3; + { + fprintf(stderr, "%s: ", icnname); + if (lineno) + fprintf(stderr, "Line %d # :", lineno); + fprintf(stderr, "\"%s\": %s%s\n", s1, s2, s3); + fflush(stderr); + } + +/* + * lfatal - issue a fatal linker error message. + */ + +void lfatal(s1, s2) +char *s1, *s2; + { + fatals++; + fprintf(stderr, "%s: ", icnname); + if (lineno) + fprintf(stderr, "Line %d # : ", lineno); + fprintf(stderr, "\"%s\": %s\n", s1, s2); + } + +/* + * setexe - mark the output file as executable + */ + +static void setexe(fname) +char *fname; + { + struct stat stbuf; + int u, r, m; + /* + * Set each of the three execute bits (owner,group,other) if allowed by + * the current umask and if the corresponding read bit is set; do not + * clear any bits already set. + */ + umask(u = umask(0)); /* get and restore umask */ + if (stat(fname,&stbuf) == 0) { /* must first read existing mode */ + r = (stbuf.st_mode & 0444) >> 2; /* get & position read bits */ + m = stbuf.st_mode | (r & ~u); /* set execute bits */ + chmod(fname,m); /* change file mode */ + } + } diff --git a/src/icont/link.h b/src/icont/link.h new file mode 100644 index 0000000..f49d436 --- /dev/null +++ b/src/icont/link.h @@ -0,0 +1,143 @@ +/* + * External declarations for the linker. + */ + +#include "../h/rt.h" + +/* + * Miscellaneous external declarations. + */ + +extern FILE *infile; /* current input file */ +extern FILE *outfile; /* linker output file */ +extern FILE *dbgfile; /* debug file */ +extern char inname[]; /* input file name */ +extern char icnname[]; /* source program file name */ +extern int lineno; /* source program line number (from ucode) */ +extern int colmno; /* source program column number */ + +extern int lstatics; /* total number of statics */ +extern int argoff; /* stack offset counter for arguments */ +extern int dynoff; /* stack offset counter for locals */ +extern int static1; /* first static in procedure */ +extern int nlocal; /* number of locals in local table */ +extern int nconst; /* number of constants in constant table */ +extern int nrecords; /* number of records in program */ +extern int trace; /* initial setting of &trace */ +extern char ixhdr[]; /* header line for direct execution */ +extern char *iconx; /* location of iconx */ +extern int hdrloc; /* location to place hdr block at */ +extern struct lfile *llfiles; /* list of files to link */ + +/* + * Structures for symbol table entries. + */ + +struct lentry { /* local table entry */ + word l_name; /* index into string space of variable name */ + int l_flag; /* variable flags */ + union { /* value field */ + int staticid; /* unique id for static variables */ + word offset; /* stack offset for args and locals */ + struct gentry *global; /* global table entry */ + } l_val; + }; + +struct gentry { /* global table entry */ + struct gentry *g_blink; /* link for bucket chain */ + word g_name; /* index into string space of variable name */ + int g_flag; /* variable flags */ + int g_nargs; /* number of args or fields */ + int g_procid; /* procedure or record id */ + word g_pc; /* position in icode of object */ + int g_index; /* "index" in global table */ + struct gentry **g_refs; /* other globals referenced, if a proc */ + struct gentry *g_next; /* next global in table */ + }; + +struct centry { /* constant table entry */ + int c_flag; /* type of literal flag */ + union xval c_val; /* value field */ + int c_length; /* length of literal string */ + word c_pc; /* position in icode of object */ + }; + +struct ientry { /* identifier table entry */ + struct ientry *i_blink; /* link for bucket chain */ + word i_name; /* index into string space of string */ + int i_length; /* length of string */ + }; + +struct fentry { /* field table header entry */ + struct fentry *f_blink; /* link for bucket chain */ + word f_name; /* index into string space of field name */ + int f_fid; /* field id */ + struct rentry *f_rlist; /* head of list of records */ + struct fentry *f_nextentry; /* next field name in allocation order */ + }; + +struct rentry { /* field table record list entry */ + struct rentry *r_link; /* link for list of records */ + struct gentry *r_gp; /* global entry for record */ + int r_fnum; /* offset of field within record */ + }; + +#include "lfile.h" + +/* + * Flag values in symbol tables. + */ + +#define F_Global 01 /* variable declared global externally */ +#define F_Unref 02 /* procedure is unreferenced */ +#define F_Proc 04 /* procedure */ +#define F_Record 010 /* record */ +#define F_Dynamic 020 /* variable declared local dynamic */ +#define F_Static 040 /* variable declared local static */ +#define F_Builtin 0100 /* identifier refers to built-in procedure */ +#define F_ImpError 0400 /* procedure has default error */ +#define F_Argument 01000 /* variable is a formal parameter */ +#define F_IntLit 02000 /* literal is an integer */ +#define F_RealLit 04000 /* literal is a real */ +#define F_StrLit 010000 /* literal is a string */ +#define F_CsetLit 020000 /* literal is a cset */ + +/* + * Symbol table region pointers. + */ + +extern struct gentry **lghash; /* hash area for global table */ +extern struct ientry **lihash; /* hash area for identifier table */ +extern struct fentry **lfhash; /* hash area for field table */ + +extern struct lentry *lltable; /* local table */ +extern struct centry *lctable; /* constant table */ +extern struct ipc_fname *fnmtbl; /* table associating ipc with file name */ +extern struct ipc_line *lntable; /* table associating ipc with line number */ +extern char *lsspace; /* string space */ +extern word *labels; /* label table */ +extern char *codeb; /* generated code space */ + +extern struct ipc_fname *fnmfree; /* free pointer for ipc/file name tbl */ +extern struct ipc_line *lnfree; /* free pointer for ipc/line number tbl */ +extern word lsfree; /* free index for string space */ +extern char *codep; /* free pointer for code space */ + +extern struct fentry *lffirst; /* first field table entry */ +extern struct fentry *lflast; /* last field table entry */ +extern struct gentry *lgfirst; /* first global table entry */ +extern struct gentry *lglast; /* last global table entry */ + + +/* + * Hash computation macros. + */ + +#define ghasher(x) (((word)x)&gmask) /* for global table */ +#define fhasher(x) (((word)x)&fmask) /* for field table */ + +/* + * Machine-dependent constants. + */ + +#define RkBlkSize(gp) ((9*WordSize)+(gp)->g_nargs * sizeof(struct descrip)) diff --git a/src/icont/llex.c b/src/icont/llex.c new file mode 100644 index 0000000..8b62d59 --- /dev/null +++ b/src/icont/llex.c @@ -0,0 +1,318 @@ +/* + * llex.c -- lexical analysis routines. + */ + +#include "link.h" +#include "tproto.h" +#include "tglobals.h" +#include "opcode.h" + +int nlflag = 0; /* newline last seen */ + +#define tonum(c) (isdigit(c) ? (c - '0') : ((c & 037) + 9)) + +/* + * getopc - get an opcode from infile, return the opcode number (via + * binary search of opcode table), and point id at the name of the opcode. + */ +int getopc(id) +char **id; + { + register char *s; + register struct opentry *p; + register int test; + word indx; + int low, high, cmp; + + indx = getstr(); + if (indx == -1) + return EOF; + s = &lsspace[indx]; + low = 0; + high = NOPCODES; + do { + test = (low + high) / 2; + p = &optable[test]; + if ((cmp = strcmp(p->op_name, s)) < 0) + low = test + 1; + else if (cmp > 0) + high = test; + else { + *id = p->op_name; + return (p->op_code); + } + } while (low < high); + *id = s; + return 0; + } + +/* + * getid - get an identifier from infile, put it in the identifier + * table, and return a index to it. + */ +word getid() + { + word indx; + + indx = getstr(); + if (indx == -1) + return EOF; + return putident((int)strlen(&lsspace[indx])+1, 1); + } + +/* + * getstr - get an identifier from infile and return an index to it. + */ +word getstr() + { + register int c; + register word indx; + + indx = lsfree; + while ((c = getc(infile)) == ' ' || c == '\t') ; + if (c == EOF) + return -1; + while (c != ' ' && c != '\t' && c != '\n' && c != ',' && c != EOF) { + if (indx >= stsize) + lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, 1, + "string space"); + lsspace[indx++] = c; + c = getc(infile); + } + if (indx >= stsize) + lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, 1, + "string space"); + lsspace[indx] = '\0'; + nlflag = (c == '\n'); + return lsfree; + } + +/* + * getrest - get the rest of the line from infile, put it in the identifier + * table, and return its index in the string space. + */ +word getrest() + { + register int c; + register word indx; + + indx = lsfree; + while ((c = getc(infile)) != '\n' && c != EOF) { + if (indx >= stsize) + lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, 1, + "string space"); + lsspace[indx++] = c; + } + if (indx >= stsize) + lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, 1, + "string space"); + lsspace[indx++] = '\0'; + nlflag = (c == '\n'); + return putident((int)(indx - lsfree), 1); + } + +/* + * getdec - get a decimal integer from infile, and return it. + */ +int getdec() + { + register int c, n; + int sign = 1, rv; + + n = 0; + while ((c = getc(infile)) == ' ' || c == '\t') ; + if (c == EOF) + return 0; + if (c == '-') { + sign = -1; + c = getc(infile); + } + while (c >= '0' && c <= '9') { + n = n * 10 + (c - '0'); + c = getc(infile); + } + nlflag = (c == '\n'); + rv = n * sign; + return rv; /* some compilers ... */ + } + +/* + * getoct - get an octal number from infile, and return it. + */ +int getoct() + { + register int c, n; + + n = 0; + while ((c = getc(infile)) == ' ' || c == '\t') ; + if (c == EOF) + return 0; + while (c >= '0' && c <= '7') { + n = (n << 3) | (c - '0'); + c = getc(infile); + } + nlflag = (c == '\n'); + return n; + } + +/* + * Get integer, but if it's too large for a long, put the string via wp + * and return -1. + */ +long getint(j,wp) + int j; + word *wp; + { + register int c; + int over = 0; + register word indx; + double result = 0; + long lresult = 0; + double radix; + + ++j; /* incase we need to add a '\0' and make it into a string */ + if (lsfree + j >= stsize) + lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, j, "string space"); + indx = lsfree; + + while ((c = getc(infile)) >= '0' && c <= '9') { + lsspace[indx++] = c; + result = result * 10 + (c - '0'); + lresult = lresult * 10 + (c - '0'); + if (result <= MinLong || result >= MaxLong) { + over = 1; /* flag overflow */ + result = 0; /* reset to avoid fp exception */ + } + } + if (c == 'r' || c == 'R') { + lsspace[indx++] = c; + radix = result; + lresult = 0; + result = 0; + while ((c = getc(infile)) != 0) { + lsspace[indx++] = c; + if (isdigit(c) || isalpha(c)) + c = tonum(c); + else + break; + result = result * radix + c; + lresult = lresult * radix + c; + if (result <= MinLong || result >= MaxLong) { + over = 1; /* flag overflow */ + result = 0; /* reset to avoid fp exception */ + } + } + } + nlflag = (c == '\n'); + if (!over) + return lresult; /* integer is small enough */ + else { /* integer is too large */ + lsspace[indx++] = '\0'; + *wp = putident((int)(indx - lsfree), 1); /* convert integer to string */ + return -1; /* indicate integer is too big */ + } + } + +/* + * getreal - get an Icon real number from infile, and return it. + */ +double getreal() + { + double n; + register int c, d, e; + int esign; + register char *s, *ep; + char cbuf[128]; + + s = cbuf; + d = 0; + while ((c = getc(infile)) == '0') + ; + while (c >= '0' && c <= '9') { + *s++ = c; + d++; + c = getc(infile); + } + if (c == '.') { + if (s == cbuf) + *s++ = '0'; + *s++ = c; + while ((c = getc(infile)) >= '0' && c <= '9') + *s++ = c; + } + ep = s; + if (c == 'e' || c == 'E') { + *s++ = c; + if ((c = getc(infile)) == '+' || c == '-') { + esign = (c == '-'); + *s++ = c; + c = getc(infile); + } + else + esign = 0; + e = 0; + while (c >= '0' && c <= '9') { + e = e * 10 + c - '0'; + *s++ = c; + c = getc(infile); + } + if (esign) e = -e; + e += d - 1; + if (abs(e) >= LogHuge) + *ep = '\0'; + } + *s = '\0'; + n = atof(cbuf); + nlflag = (c == '\n'); + return n; + } + +/* + * getlab - get a label ("L" followed by a number) from infile, + * and return the number. + */ + +int getlab() + { + register int c; + + while ((c = getc(infile)) != 'L' && c != EOF && c != '\n') ; + if (c == 'L') + return getdec(); + nlflag = (c == '\n'); + return 0; + } + +/* + * getstrlit - get a string literal from infile, as a string + * of octal bytes, and return its index into the string table. + */ +word getstrlit(l) +register int l; + { + register word indx; + + if (lsfree + l >= stsize) + lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, l, "string space"); + indx = lsfree; + while (!nlflag && l--) + lsspace[indx++] = getoct(); + if (indx >= stsize) + lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, 1, + "string space"); + lsspace[indx++] = '\0'; + return putident((int)(indx-lsfree), 1); + } + +/* + * newline - skip to next line. + */ +void newline() + { + register int c; + + if (!nlflag) { + while ((c = getc(infile)) != '\n' && c != EOF) ; + } + nlflag = 0; + } diff --git a/src/icont/lmem.c b/src/icont/lmem.c new file mode 100644 index 0000000..8e091a5 --- /dev/null +++ b/src/icont/lmem.c @@ -0,0 +1,224 @@ +/* + * lmem.c -- memory initialization and allocation; also parses arguments. + */ + +#include "link.h" +#include "tproto.h" +#include "tglobals.h" + +/* + * Prototypes. + */ + +static struct lfile *alclfile (char *name); + +void dumplfiles(void); + +/* + * Memory initialization + */ + +struct gentry **lghash; /* hash area for global table */ +struct ientry **lihash; /* hash area for identifier table */ +struct fentry **lfhash; /* hash area for field table */ + +struct lentry *lltable; /* local table */ +struct centry *lctable; /* constant table */ +struct ipc_fname *fnmtbl; /* table associating ipc with file name */ +struct ipc_line *lntable; /* table associating ipc with line number */ + +char *lsspace; /* string space */ +word *labels; /* label table */ +char *codeb; /* generated code space */ + +struct ipc_fname *fnmfree; /* free pointer for ipc/file name table */ +struct ipc_line *lnfree; /* free pointer for ipc/line number table */ +word lsfree; /* free index for string space */ +char *codep; /* free pointer for code space */ + +struct fentry *lffirst; /* first field table entry */ +struct fentry *lflast; /* last field table entry */ +struct gentry *lgfirst; /* first global table entry */ +struct gentry *lglast; /* last global table entry */ + +/* + * linit - scan the command line arguments and initialize data structures. + */ +void linit() + { + struct gentry **gp; + struct ientry **ip; + struct fentry **fp; + + llfiles = NULL; /* Zero queue of files to link. */ + + /* + * Allocate the various data structures that are used by the linker. + */ + lghash = (struct gentry **) tcalloc(ghsize, sizeof(struct gentry *)); + lihash = (struct ientry **) tcalloc(ihsize, sizeof(struct ientry *)); + lfhash = (struct fentry **) tcalloc(fhsize, sizeof(struct fentry *)); + + lltable = (struct lentry *) tcalloc(lsize, sizeof(struct lentry)); + lctable = (struct centry *) tcalloc(csize, sizeof(struct centry)); + + lnfree = lntable = (struct ipc_line*)tcalloc(nsize,sizeof(struct ipc_line)); + + lsspace = (char *) tcalloc(stsize, sizeof(char)); + lsfree = 0; + + fnmtbl = (struct ipc_fname *) tcalloc(fnmsize, sizeof(struct ipc_fname)); + fnmfree = fnmtbl; + + labels = (word *) tcalloc(maxlabels, sizeof(word)); + codep = codeb = (char *) tcalloc(maxcode, 1); + + lffirst = NULL; + lflast = NULL; + lgfirst = NULL; + lglast = NULL; + + /* + * Zero out the hash tables. + */ + for (gp = lghash; gp < &lghash[ghsize]; gp++) + *gp = NULL; + for (ip = lihash; ip < &lihash[ihsize]; ip++) + *ip = NULL; + for (fp = lfhash; fp < &lfhash[fhsize]; fp++) + *fp = NULL; + + /* + * Install "main" as a global variable in order to insure that it + * is the first global variable. iconx/start.s depends on main + * being global number 0. + */ + putglobal(instid("main"), F_Global, 0, 0); + } + +#ifdef DeBugLinker + /* + * dumplfiles - print the list of files to link. Used for debugging only. + */ + void dumplfiles() + { + struct lfile *p,*lfls; + + fprintf(stderr,"lfiles:\n"); + lfls = llfiles; + while (p = getlfile(&lfls)) + fprintf(stderr,"'%s'\n",p->lf_name); + fflush(stderr); + } +#endif /* DeBugLinker */ + +/* + * alsolink - create an lfile structure for the named file and add it to the + * end of the list of files (llfiles) to generate link instructions for. + */ +void alsolink(name) +char *name; + { + struct lfile *nlf, *p; + char file[MaxPath]; + + if (!pathfind(file, ipath, name, U1Suffix)) + quitf("cannot resolve reference to file '%s'",name); + + nlf = alclfile(file); + if (llfiles == NULL) { + llfiles = nlf; + } + else { + p = llfiles; + while (p->lf_link != NULL) { + if (strcmp(p->lf_name,file) == 0) + return; + p = p->lf_link; + } + if (strcmp(p->lf_name,file) == 0) + return; + p->lf_link = nlf; + } + } + +/* + * getlfile - return a pointer (p) to the lfile structure pointed at by lptr + * and move lptr to the lfile structure that p points at. That is, getlfile + * returns a pointer to the current (wrt. lptr) lfile and advances lptr. + */ +struct lfile *getlfile(lptr) +struct lfile **lptr; + { + struct lfile *p; + + if (*lptr == NULL) + return (struct lfile *)NULL; + else { + p = *lptr; + *lptr = p->lf_link; + return p; + } + } + +/* + * alclfile - allocate an lfile structure for the named file, fill + * in the name and return a pointer to it. + */ +static struct lfile *alclfile(name) +char *name; + { + struct lfile *p; + + p = (struct lfile *) alloc(sizeof(struct lfile)); + p->lf_link = NULL; + p->lf_name = salloc(name); + return p; + } + +/* + * lmfree - free memory used by the linker + */ +void lmfree() + { + struct fentry *fp, *fp1; + struct gentry *gp, *gp1; + struct rentry *rp, *rp1; + struct ientry *ip, *ip1; + int i; + + for (i = 0; i < ihsize; ++i) + for (ip = lihash[i]; ip != NULL; ip = ip1) { + ip1 = ip->i_blink; + free((char *)ip); + } + + free((char *) lghash); lghash = NULL; + free((char *) lihash); lihash = NULL; + free((char *) lfhash); lfhash = NULL; + free((char *) lltable); lltable = NULL; + free((char *) lctable); lctable = NULL; + free((char *) lntable); lntable = NULL; + free((char *) lsspace); lsspace = NULL; + free((char *) fnmtbl); fnmtbl = NULL; + free((char *) labels); labels = NULL; + free((char *) codep); codep = NULL; + + for (fp = lffirst; fp != NULL; fp = fp1) { + for(rp = fp->f_rlist; rp != NULL; rp = rp1) { + rp1 = rp->r_link; + free((char *)rp); + } + fp1 = fp->f_nextentry; + free((char *)fp); + } + lffirst = NULL; + lflast = NULL; + + for (gp = lgfirst; gp != NULL; gp = gp1) { + gp1 = gp->g_next; + free((char *)gp); + } + lgfirst = NULL; + lglast = NULL; + } diff --git a/src/icont/lnklist.c b/src/icont/lnklist.c new file mode 100644 index 0000000..f322355 --- /dev/null +++ b/src/icont/lnklist.c @@ -0,0 +1,83 @@ +/* + * lnklist.c -- functions for handling file linking. + */ + +#include "../h/gsupport.h" +#include "tproto.h" +#include "lfile.h" + +/* + * Prototype. + */ +static struct lfile *alclfile (char *name); + +struct lfile *lfiles; +struct invkl *invkls; + +/* + * addinvk adds an "invokable" name to the list. + * n==1 if name is an identifier; otherwise it is a string literal. + */ +void addinvk(name, n) +char *name; +int n; + { + struct invkl *p; + + if (n == 1) { /* if identifier, must be "all" */ + if (strcmp(name, "all") != 0) { + tfatal("invalid operand to invocable", name); + return; + } + else + name = "0"; /* "0" represents "all" */ + } + else if (!isalpha(name[0]) && (name[0] != '_')) + return; /* if operator, ignore */ + + p = alloc(sizeof(struct invkl)); + if (!p) + tsyserr("not enough memory for invocable list"); + p->iv_name = salloc(name); + p->iv_link = invkls; + invkls = p; + } + +/* + * alclfile allocates an lfile structure for the named file, fills + * in the name and returns a pointer to it. + */ +static struct lfile *alclfile(name) +char *name; + { + struct lfile *p; + + p = alloc(sizeof(struct lfile)); + if (!p) + tsyserr("not enough memory for file list"); + p->lf_link = NULL; + p->lf_name = salloc(name); + return p; + } + +/* + * addlfile creates an lfile structure for the named file and add it to the + * end of the list of files (lfiles) to generate link instructions for. + */ +void addlfile(name) +char *name; + { + struct lfile *nlf, *p; + + nlf = alclfile(name); + if (lfiles == NULL) { + lfiles = nlf; + } + else { + p = lfiles; + while (p->lf_link != NULL) { + p = p->lf_link; + } + p->lf_link = nlf; + } + } diff --git a/src/icont/lsym.c b/src/icont/lsym.c new file mode 100644 index 0000000..83b6768 --- /dev/null +++ b/src/icont/lsym.c @@ -0,0 +1,446 @@ +/* + * lsym.c -- functions for symbol table manipulation. + */ + +#include "link.h" +#include "tproto.h" +#include "tglobals.h" + +/* + * Prototypes. + */ + +static struct fentry *alcfhead + (struct fentry *blink, word name, int fid, struct rentry *rlist); +static struct rentry *alcfrec + (struct rentry *link, struct gentry *gp, int fnum); +static struct gentry *alcglobal + (struct gentry *blink, word name, int flag, int nargs, int procid); +static struct ientry *alcident (char *nam, int len); + +int dynoff; /* stack offset counter for locals */ +int argoff; /* stack offset counter for arguments */ +int static1; /* first static in procedure */ +int lstatics = 0; /* static variable counter */ + +int nlocal; /* number of locals in local table */ +int nconst; /* number of constants in constant table */ +int nfields = 0; /* number of fields in field table */ + +/* + * instid - copy the string s to the start of the string free space + * and call putident with the length of the string. + */ +word instid(s) +char *s; + { + register int l; + register word indx; + register char *p; + + indx = lsfree; + p = s; + l = 0; + do { + if (indx >= stsize) + lsspace = (char *)trealloc(lsspace, NULL, &stsize, 1, 1, + "string space"); + l++; + } while ((lsspace[indx++] = *p++) != 0); + + return putident(l, 1); + } + +/* + * putident - install the identifier named by the string starting at lsfree + * and extending for len bytes. The installation entails making an + * entry in the identifier hash table and then making an identifier + * table entry for it with alcident. A side effect of installation + * is the incrementing of lsfree by the length of the string, thus + * "saving" it. + * + * Nothing is changed if the identifier has already been installed. + * + * If "install" is 0, putident returns -1 for a nonexistent identifier, + * and does not install it. + */ +word putident(len, install) +int len, install; + { + register int hash; + register char *s; + register struct ientry *ip; + int l; + + /* + * Compute hash value by adding bytes and masking result with imask. + * (Recall that imask is ihsize-1.) + */ + s = &lsspace[lsfree]; + hash = 0; + l = len; + while (l--) + hash += *s++; + l = len; + s = &lsspace[lsfree]; + hash &= imask; + /* + * If the identifier hasn't been installed, install it. + */ + if ((ip = lihash[hash]) != NULL) { /* collision */ + for (;;) { + /* + * follow i_blink chain until id is found or end of chain reached + */ + if (l == ip->i_length && lexeql(l, s, &lsspace[ip->i_name])) + return ip->i_name; /* id is already installed, return it */ + if (ip->i_blink == NULL) { /* end of chain */ + if (install == 0) + return -1; + ip->i_blink = alcident(s, l); + lsfree += l; + return ip->i_blink->i_name; + } + ip = ip->i_blink; + } + } + /* + * Hashed to an empty slot. + */ + if (install == 0) + return -1; + lihash[hash] = alcident(s, l); + lsfree += l; + return lihash[hash]->i_name; + } + +/* + * lexeql - compare two strings of given length. Returns non-zero if + * equal, zero if not equal. + */ +int lexeql(l, s1, s2) +register int l; +register char *s1, *s2; + { + while (l--) + if (*s1++ != *s2++) + return 0; + return 1; + } + +/* + * alcident - get the next free identifier table entry, and fill it in with + * the specified values. + */ +static struct ientry *alcident(nam, len) +char *nam; +int len; + { + register struct ientry *ip; + + ip = NewStruct(ientry); + ip->i_blink = NULL; + ip->i_name = (word)(nam - lsspace); + ip->i_length = len; + return ip; + } + +/* + * locinit - clear local symbol table. + */ +void locinit() + { + dynoff = 0; + argoff = 0; + nlocal = -1; + nconst = -1; + static1 = lstatics; + } + +/* + * putlocal - make a local symbol table entry. + */ +void putlocal(n, id, flags, imperror, procname) +int n; +word id; +register int flags; +int imperror; +word procname; + { + register struct lentry *lp; + union { + struct gentry *gp; + int bn; + } p; + + if (n >= lsize) + lltable = (struct lentry *)trealloc(lltable, NULL, &lsize, + sizeof(struct lentry), 1, "local symbol table"); + if (n > nlocal) + nlocal = n; + lp = &lltable[n]; + lp->l_name = id; + lp->l_flag = flags; + if (flags == 0) { /* undeclared */ + if ((p.gp = glocate(id)) != NULL) { /* check global */ + lp->l_flag = F_Global; + lp->l_val.global = p.gp; + } + + else if ((p.bn = blocate(id)) != 0) { /* check for function */ + lp->l_flag = F_Builtin | F_Global; + lp->l_val.global = putglobal(id, F_Builtin | F_Proc, -1, p.bn); + } + + else { /* implicit local */ + if (imperror) + lwarn(&lsspace[id], "undeclared identifier, procedure ", + &lsspace[procname]); + lp->l_flag = F_Dynamic; + lp->l_val.offset = ++dynoff; + } + } + else if (flags & F_Global) { /* global variable */ + if ((p.gp = glocate(id)) == NULL) + quit("putlocal: global not in global table"); + lp->l_val.global = p.gp; + } + else if (flags & F_Argument) /* procedure argument */ + lp->l_val.offset = ++argoff; + else if (flags & F_Dynamic) /* local dynamic */ + lp->l_val.offset = ++dynoff; + else if (flags & F_Static) /* local static */ + lp->l_val.staticid = ++lstatics; + else + quit("putlocal: unknown flags"); + } + +/* + * putglobal - make a global symbol table entry. + */ +struct gentry *putglobal(id, flags, nargs, procid) +word id; +int flags; +int nargs; +int procid; + { + register struct gentry *p; + + flags |= F_Global; + if ((p = glocate(id)) == NULL) { /* add to head of hash chain */ + p = lghash[ghasher(id)]; + lghash[ghasher(id)] = alcglobal(p, id, flags, nargs, procid); + return lghash[ghasher(id)]; + } + p->g_flag |= flags; + p->g_nargs = nargs; + p->g_procid = procid; + return p; + } + +/* + * putconst - make a constant symbol table entry. + */ +void putconst(n, flags, len, pc, valp) +int n; +int flags, len; +word pc; +union xval *valp; + + { + register struct centry *p; + if (n >= csize) + lctable = (struct centry *)trealloc(lctable, NULL, &csize, + sizeof(struct centry), 1, "constant table"); + if (nconst < n) + nconst = n; + p = &lctable[n]; + p->c_flag = flags; + p->c_pc = pc; + if (flags & F_IntLit) { + p->c_val.ival = valp->ival; + } + else if (flags & F_StrLit) { + p->c_val.sval = valp->sval; + p->c_length = len; + } + else if (flags & F_CsetLit) { + p->c_val.sval = valp->sval; + p->c_length = len; + } + else if (flags & F_RealLit) { + #ifdef Double + /* + * Access real values one word at a time. + */ + int *rp, *rq; + rp = (int *) &(p->c_val.rval); + rq = (int *) &(valp->rval); + *rp++ = *rq++; + *rp = *rq; + #else /* Double */ + p->c_val.rval = valp->rval; + #endif /* Double */ + } + else + fprintf(stderr, "putconst: bad flags: %06o %011lo\n", flags, valp->ival); + } + +/* + * putfield - make a record/field table entry. + */ +void putfield(fname, gp, fnum) +word fname; +struct gentry *gp; +int fnum; + { + register struct fentry *fp; + register struct rentry *rp, *rp2; + word hash; + + fp = flocate(fname); + if (fp == NULL) { /* create a field entry */ + nfields++; + hash = fhasher(fname); + fp = lfhash[hash]; + lfhash[hash] = alcfhead(fp, fname, nfields, alcfrec((struct rentry *)NULL, + gp, fnum)); + return; + } + rp = fp->f_rlist; /* found field entry; */ + if (rp->r_gp->g_procid > gp->g_procid) { /* find spot in record list */ + fp->f_rlist = alcfrec(rp, gp, fnum); + return; + } + while (rp->r_gp->g_procid < gp->g_procid) { /* keep record list ascending */ + if (rp->r_link == NULL) { + rp->r_link = alcfrec((struct rentry *)NULL, gp, fnum); + return; + } + rp2 = rp; + rp = rp->r_link; + } + rp2->r_link = alcfrec(rp, gp, fnum); + } + +/* + * glocate - lookup identifier in global symbol table, return NULL + * if not present. + */ +struct gentry *glocate(id) +word id; + { + register struct gentry *p; + + p = lghash[ghasher(id)]; + while (p != NULL && p->g_name != id) + p = p->g_blink; + return p; + } + +/* + * flocate - lookup identifier in field table. + */ +struct fentry *flocate(id) +word id; + { + register struct fentry *p; + + p = lfhash[fhasher(id)]; + while (p != NULL && p->f_name != id) + p = p->f_blink; + return p; + } + +/* + * alcglobal - create a new global symbol table entry. + */ +static struct gentry *alcglobal(blink, name, flag, nargs, procid) +struct gentry *blink; +word name; +int flag; +int nargs; +int procid; + { + register struct gentry *gp; + + gp = NewStruct(gentry); + gp->g_blink = blink; + gp->g_name = name; + gp->g_flag = flag; + gp->g_nargs = nargs; + gp->g_procid = procid; + gp->g_next = NULL; + if (lgfirst == NULL) { + lgfirst = gp; + gp->g_index = 0; + } + else { + lglast->g_next = gp; + gp->g_index = lglast->g_index + 1; + } + lglast = gp; + return gp; + } + +/* + * alcfhead - allocate a field table header. + */ +static struct fentry *alcfhead(blink, name, fid, rlist) +struct fentry *blink; +word name; +int fid; +struct rentry *rlist; + { + register struct fentry *fp; + + fp = NewStruct(fentry); + fp->f_blink = blink; + fp->f_name = name; + fp->f_fid = fid; + fp->f_rlist = rlist; + fp->f_nextentry = NULL; + if (lffirst == NULL) + lffirst = fp; + else + lflast->f_nextentry = fp; + lflast = fp; + return fp; + } + +/* + * alcfrec - allocate a field table record list element. + */ +static struct rentry *alcfrec(link, gp, fnum) +struct rentry *link; +struct gentry *gp; +int fnum; + { + register struct rentry *rp; + + rp = NewStruct(rentry); + rp->r_link = link; + rp->r_gp = gp; + rp->r_fnum = fnum; + return rp; + } + +/* + * blocate - search for a function. The search is linear to make + * it easier to add/delete functions. If found, returns index+1 for entry. + */ + +int blocate(s_indx) +word s_indx; + { +register char *s; + register int i; + extern char *ftable[]; + extern int ftbsize; + + s = &lsspace[s_indx]; + for (i = 0; i < ftbsize; i++) + if (strcmp(ftable[i], s) == 0) + return i + 1; + return 0; + } diff --git a/src/icont/mkkwd.icn b/src/icont/mkkwd.icn new file mode 100644 index 0000000..14af432 --- /dev/null +++ b/src/icont/mkkwd.icn @@ -0,0 +1,52 @@ +# mkkwd.icn +# +# reads: standard input (typically ../runtime/keywords.r) +# +# writes: keyword.c +# keyword.h +# kdefs.h + +procedure main() + local kywds, klist, line, f, k, i + + # load keywords + kywds := set() + while line := read() do { + line ? { + if ="keyword" then { + tab(find("}")+1) + tab(many(' \t')) + insert(kywds,tab(0)) + } + } + } + klist := sort(kywds) + + # write defined constants to keyword.h + hfile := wopen("keyword.h", "Keyword manifest constants") + lfile := wopen("../h/kdefs.h", "Keyword list") + i := 0 + every k := !klist do { + kname := "K_" || map(k,&lcase,&ucase) + write(hfile, "#define ", left(kname,13), right(i+:=1,3)) + write(lfile, "KDef(", k, ",", kname, ")") + } +end + + +# wopen(fname,comment) -- open file for writing +# +# opens and returns file; writes header comment; writes message to stdout + +procedure wopen(fname,comment) + local f + f := open(fname, "w") | stop ("can't open ", fname, " for writing") + write(f, "/*") + write(f, " * ", fname, " -- ", comment, ".") + write(f, " *") + write(f, " * Created mechanically by mkkwd.icn -- DO NOT EDIT.") + write(f, " */") + write(f) + write(" writing ", fname) + return f +end diff --git a/src/icont/newhdr.c b/src/icont/newhdr.c new file mode 100644 index 0000000..7e23edb --- /dev/null +++ b/src/icont/newhdr.c @@ -0,0 +1,90 @@ +/* + * Intermediate program to convert iconx.hdr into a header file for inclusion + * in icont. This eliminates a compile-time file search on Unix systems. + * Definition of BinaryHeader activates the inclusion. + */ + +#include "../h/gsupport.h" + +void putbyte(FILE *fout, int b); + +int main(int argc, char *argv[]) + { + static const char Usage[] = "Usage %s [Filename]\n"; + int b, n; + char *ifile = NULL; + char *ofile = NULL; + FILE *fin, *fout; + + n = 1; + if (((n + 1) < argc) && !strcmp(argv[n], "-o")) { + ofile = argv[++n]; + ++n; + } + if (n < argc) + ifile = argv[n++]; + + if (ifile == NULL) + fin = stdin; + else if ((fin = fopen(ifile, "rb")) == NULL) { + fprintf(stderr, "Cannot open \"%s\" for input\n\n", ifile); + fprintf(stderr, Usage, argv[0]); + return EXIT_FAILURE; + } + + if (ofile == NULL) + fout = stdout; + else if ((fout = fopen(ofile, "w")) == NULL) { + fprintf(stderr, "Cannot open \"%s\" for output\n\n", ofile); + fprintf(stderr, Usage, argv[0]); + return EXIT_FAILURE; + } + + /* + * Create an array large enough to hold iconx.hdr (+1 for luck) + * This array shall be included by link.c (and is nominally called + * hdr.h) + */ + fprintf(fout, "static unsigned char iconxhdr[MaxHdr+1] = {\n"); + + /* + * Recreate iconx.hdr as a series of hex constants, padded with zero bytes. + */ + for (n = 0; (b = getc(fin)) != EOF; n++) + putbyte(fout, b); + + /* + * If header is to be used, make sure it fits. + */ + #ifdef BinaryHeader + if (n > MaxHdr) { + fprintf(stderr, "%s: file size is %d bytes but MaxHdr is only %d\n", + argv[0], n, MaxHdr); + if (ofile != NULL) { + fclose(fout); + unlink(ofile); + } + return EXIT_FAILURE; + } + #endif /* BinaryHeader */ + + while (n++ < MaxHdr) + putbyte(fout, 0); + fprintf(fout,"0x00};\n"); /* one more, sans comma, and finish */ + + return EXIT_SUCCESS; + } + +/* + * putbyte(b) - output byte b as two hex digits + */ +void putbyte(FILE *fout, int b) + { + static int n = 0; + + fprintf(fout, "0x%02x,", b & 0xFF); + if (++n == 16) { + fprintf(fout, "\n"); + n = 0; + } + } diff --git a/src/icont/opcode.c b/src/icont/opcode.c new file mode 100644 index 0000000..a7d557e --- /dev/null +++ b/src/icont/opcode.c @@ -0,0 +1,117 @@ +#include "link.h" +#include "tproto.h" +#include "opcode.h" + +/* + * Opcode table. + */ + +struct opentry optable[] = { + "asgn", Op_Asgn, + "bang", Op_Bang, + + "bscan", Op_Bscan, + + "cat", Op_Cat, + "ccase", Op_Ccase, + "chfail", Op_Chfail, + "coact", Op_Coact, + "cofail", Op_Cofail, + "colm", Op_Colm, /* always recognized, possibly ignored*/ + "compl", Op_Compl, + "con", Op_Con, + "coret", Op_Coret, + "create", Op_Create, + "cset", Op_Cset, + "declend", Op_Declend, + "diff", Op_Diff, + "div", Op_Div, + "dup", Op_Dup, + "efail", Op_Efail, + "end", Op_End, + "eqv", Op_Eqv, + "eret", Op_Eret, + "error", Op_Error, + "escan", Op_Escan, + "esusp", Op_Esusp, + "field", Op_Field, + "filen", Op_Filen, + + "global", Op_Global, + "goto", Op_Goto, + "impl", Op_Impl, + "init", Op_Init, + "int", Op_Int, + "inter", Op_Inter, + "invocable", Op_Invocable, + "invoke", Op_Invoke, + "keywd", Op_Keywd, + "lab", Op_Lab, + "lconcat", Op_Lconcat, + "lexeq", Op_Lexeq, + "lexge", Op_Lexge, + "lexgt", Op_Lexgt, + "lexle", Op_Lexle, + "lexlt", Op_Lexlt, + "lexne", Op_Lexne, + "limit", Op_Limit, + "line", Op_Line, + "link", Op_Link, + "llist", Op_Llist, + "local", Op_Local, + "lsusp", Op_Lsusp, + "mark", Op_Mark, + "mark0", Op_Mark0, + "minus", Op_Minus, + "mod", Op_Mod, + "mult", Op_Mult, + "neg", Op_Neg, + "neqv", Op_Neqv, + "nonnull", Op_Nonnull, + +#ifdef LineCodes + "noop", Op_Noop, +#endif /* LineCodes */ + + "null", Op_Null, + "number", Op_Number, + "numeq", Op_Numeq, + "numge", Op_Numge, + "numgt", Op_Numgt, + "numle", Op_Numle, + "numlt", Op_Numlt, + "numne", Op_Numne, + "pfail", Op_Pfail, + "plus", Op_Plus, + "pnull", Op_Pnull, + "pop", Op_Pop, + "power", Op_Power, + "pret", Op_Pret, + "proc", Op_Proc, + "psusp", Op_Psusp, + "push1", Op_Push1, + "pushn1", Op_Pushn1, + "random", Op_Random, + "rasgn", Op_Rasgn, + "real", Op_Real, + "record", Op_Record, + "refresh", Op_Refresh, + "rswap", Op_Rswap, + "sdup", Op_Sdup, + "sect", Op_Sect, + "size", Op_Size, + "str", Op_Str, + "subsc", Op_Subsc, + "swap", Op_Swap, + "tabmat", Op_Tabmat, + "tally", Op_Tally, + "toby", Op_Toby, + "trace", Op_Trace, + "unions", Op_Unions, + "unmark", Op_Unmark, + "value", Op_Value, + "var", Op_Var, + "version", Op_Version, + }; + +int NOPCODES = sizeof(optable) / sizeof(struct opentry); diff --git a/src/icont/opcode.h b/src/icont/opcode.h new file mode 100644 index 0000000..ca98cf1 --- /dev/null +++ b/src/icont/opcode.h @@ -0,0 +1,17 @@ +/* + * Opcode table structure. + */ + +struct opentry { + char *op_name; /* name of opcode */ + int op_code; /* opcode number */ + }; + +/* + * External definitions. + */ + +extern struct opentry optable[]; +extern int NOPCODES; + +#include "../h/opdefs.h" diff --git a/src/icont/tcode.c b/src/icont/tcode.c new file mode 100644 index 0000000..9a9787c --- /dev/null +++ b/src/icont/tcode.c @@ -0,0 +1,1097 @@ +/* + * tcode.c -- translator functions for traversing parse trees and generating + * code. + */ + +#include "../h/gsupport.h" +#include "tproto.h" +#include "tglobals.h" +#include "tree.h" +#include "ttoken.h" +#include "tsym.h" + +/* + * Prototypes. + */ + +static int alclab (int n); +static void binop (int op); +static void emit (char *s); +static void emitl (char *s,int a); +static void emitlab (int l); +static void emitn (char *s,int a); +static void emits (char *s,char *a); +static void emitfile (nodeptr n); +static void emitline (nodeptr n); +static void setloc (nodeptr n); +static int traverse (nodeptr t); +static void unopa (int op, nodeptr t); +static void unopb (int op); + +extern int tfatals; +extern int nocode; + +/* + * Code generator parameters. + */ + +#define LoopDepth 20 /* max. depth of nested loops */ +#define CaseDepth 10 /* max. depth of nested case statements */ +#define CreatDepth 10 /* max. depth of nested create statements */ + +/* + * loopstk structures hold information about nested loops. + */ +struct loopstk { + int nextlab; /* label for next exit */ + int breaklab; /* label for break exit */ + int markcount; /* number of marks */ + int ltype; /* loop type */ + }; + +/* + * casestk structure hold information about case statements. + */ +struct casestk { + int endlab; /* label for exit from case statement */ + nodeptr deftree; /* pointer to tree for default clause */ + }; + +/* + * creatstk structures hold information about create statements. + */ +struct creatstk { + int nextlab; /* previous value of nextlab */ + int breaklab; /* previous value of breaklab */ + }; +static int nextlab; /* next label allocated by alclab() */ + +/* + * codegen - traverse tree t, generating code. + */ + +void codegen(t) +nodeptr t; + { + nextlab = 1; + traverse(t); + } + +/* + * traverse - traverse tree rooted at t and generate code. This is just + * plug and chug code for each of the node types. + */ + +static int traverse(t) +register nodeptr t; + { + register int lab, n, i; + struct loopstk loopsave; + static struct loopstk loopstk[LoopDepth]; /* loop stack */ + static struct loopstk *loopsp; + static struct casestk casestk[CaseDepth]; /* case stack */ + static struct casestk *casesp; + static struct creatstk creatstk[CreatDepth]; /* create stack */ + static struct creatstk *creatsp; + + n = 1; + switch (TType(t)) { + + case N_Activat: /* co-expression activation */ + if (Val0(Tree0(t)) == AUGAT) { + emit("pnull"); + } + traverse(Tree2(t)); /* evaluate result expression */ + if (Val0(Tree0(t)) == AUGAT) + emit("sdup"); + traverse(Tree1(t)); /* evaluate activate expression */ + setloc(t); + emit("coact"); + if (Val0(Tree0(t)) == AUGAT) + emit("asgn"); + free(Tree0(t)); + break; + + case N_Alt: /* alternation */ + lab = alclab(2); + emitl("mark", lab); + loopsp->markcount++; + traverse(Tree0(t)); /* evaluate first alternative */ + loopsp->markcount--; + #ifdef EventMon + setloc(t); + #endif /* EventMon */ + emit("esusp"); /* and suspend with its result */ + emitl("goto", lab+1); + emitlab(lab); + traverse(Tree1(t)); /* evaluate second alternative */ + emitlab(lab+1); + break; + + case N_Augop: /* augmented assignment */ + case N_Binop: /* or a binary operator */ + emit("pnull"); + traverse(Tree1(t)); + if (TType(t) == N_Augop) + emit("dup"); + traverse(Tree2(t)); + setloc(t); + binop((int)Val0(Tree0(t))); + free(Tree0(t)); + break; + + case N_Bar: /* repeated alternation */ + lab = alclab(1); + emitlab(lab); + emit("mark0"); /* fail if expr fails first time */ + loopsp->markcount++; + traverse(Tree0(t)); /* evaluate first alternative */ + loopsp->markcount--; + emitl("chfail", lab); /* change to loop on failure */ + emit("esusp"); /* suspend result */ + break; + + case N_Break: /* break expression */ + if (loopsp->breaklab <= 0) + nfatal(t, "invalid context for break", NULL); + else { + for (i = 0; i < loopsp->markcount; i++) + emit("unmark"); + loopsave = *loopsp--; + traverse(Tree0(t)); + *++loopsp = loopsave; + emitl("goto", loopsp->breaklab); + } + break; + + case N_Case: /* case expression */ + lab = alclab(1); + casesp++; + casesp->endlab = lab; + casesp->deftree = NULL; + emit("mark0"); + loopsp->markcount++; + traverse(Tree0(t)); /* evaluate control expression */ + loopsp->markcount--; + emit("eret"); + traverse(Tree1(t)); /* do rest of case (CLIST) */ + if (casesp->deftree != NULL) { /* evaluate default clause */ + emit("pop"); + traverse(casesp->deftree); + } + else + emit("efail"); + emitlab(lab); /* end label */ + casesp--; + break; + + case N_Ccls: /* case expression clause */ + if (TType(Tree0(t)) == N_Res && /* default clause */ + Val0(Tree0(t)) == DEFAULT) { + if (casesp->deftree != NULL) + nfatal(t, "more than one default clause", NULL); + else + casesp->deftree = Tree1(t); + free(Tree0(t)); + } + else { /* case clause */ + lab = alclab(1); + emitl("mark", lab); + loopsp->markcount++; + emit("ccase"); + traverse(Tree0(t)); /* evaluate selector */ + setloc(t); + emit("eqv"); + loopsp->markcount--; + emit("unmark"); + emit("pop"); + traverse(Tree1(t)); /* evaluate expression */ + emitl("goto", casesp->endlab); /* goto end label */ + emitlab(lab); /* label for next clause */ + } + break; + + case N_Clist: /* list of case clauses */ + traverse(Tree0(t)); + traverse(Tree1(t)); + break; + + case N_Conj: /* conjunction */ + if (Val0(Tree0(t)) == AUGAND) { + emit("pnull"); + } + traverse(Tree1(t)); + if (Val0(Tree0(t)) != AUGAND) + emit("pop"); + traverse(Tree2(t)); + if (Val0(Tree0(t)) == AUGAND) { + setloc(t); + emit("asgn"); + } + free(Tree0(t)); + break; + + case N_Create: /* create expression */ + creatsp++; + creatsp->nextlab = loopsp->nextlab; + creatsp->breaklab = loopsp->breaklab; + loopsp->nextlab = 0; /* make break and next illegal */ + loopsp->breaklab = 0; + lab = alclab(3); + emitl("goto", lab+2); /* skip over code for co-expression */ + emitlab(lab); /* entry point */ + emit("pop"); /* pop the result from activation */ + emitl("mark", lab+1); + loopsp->markcount++; + traverse(Tree0(t)); /* traverse code for co-expression */ + loopsp->markcount--; + setloc(t); + emit("coret"); /* return to activator */ + emit("efail"); /* drive co-expression */ + emitlab(lab+1); /* loop on exhaustion */ + emit("cofail"); /* and fail each time */ + emitl("goto", lab+1); + emitlab(lab+2); + emitl("create", lab); /* create entry block */ + loopsp->nextlab = creatsp->nextlab; /* legalize break and next */ + loopsp->breaklab = creatsp->breaklab; + creatsp--; + break; + + case N_Cset: /* cset literal */ + emitn("cset", (int)Val0(t)); + break; + + case N_Elist: /* expression list */ + n = traverse(Tree0(t)); + n += traverse(Tree1(t)); + break; + + case N_Empty: /* a missing expression */ + emit("pnull"); + break; + + case N_Field: /* field reference */ + emit("pnull"); + traverse(Tree0(t)); + setloc(t); + emits("field", Str0(Tree1(t))); + free(Tree1(t)); + break; + + case N_Id: /* identifier */ + emitn("var", (int)Val0(t)); + break; + + case N_If: /* if expression */ + if (TType(Tree2(t)) == N_Empty) { + lab = 0; + emit("mark0"); + } + else { + lab = alclab(2); + emitl("mark", lab); + } + loopsp->markcount++; + traverse(Tree0(t)); + loopsp->markcount--; + emit("unmark"); + traverse(Tree1(t)); + if (lab > 0) { + emitl("goto", lab+1); + emitlab(lab); + traverse(Tree2(t)); + emitlab(lab+1); + } + else + free(Tree2(t)); + break; + + case N_Int: /* integer literal */ + emitn("int", (int)Val0(t)); + break; + + case N_Apply: /* application */ + traverse(Tree0(t)); + traverse(Tree1(t)); + emitn("invoke", -1); + break; + + case N_Invok: /* invocation */ + if (TType(Tree0(t)) != N_Empty) { + traverse(Tree0(t)); + } + else { + emit("pushn1"); /* default to -1(e1,...,en) */ + free(Tree0(t)); + } + if (TType(Tree1(t)) == N_Empty) { + n = 0; + free(Tree1(t)); + } + else + n = traverse(Tree1(t)); + setloc(t); + emitn("invoke", n); + n = 1; + break; + + case N_Key: /* keyword reference */ + setloc(t); + emits("keywd", Str0(t)); + break; + + case N_Limit: /* limitation */ + traverse(Tree1(t)); + setloc(t); + emit("limit"); + loopsp->markcount++; + traverse(Tree0(t)); + loopsp->markcount--; + emit("lsusp"); + break; + + case N_List: /* list construction */ + emit("pnull"); + if (TType(Tree0(t)) == N_Empty) { + n = 0; + free(Tree0(t)); + } + else + n = traverse(Tree0(t)); + setloc(t); + emitn("llist", n); + n = 1; + break; + + case N_Loop: /* loop */ + switch ((int)Val0(Tree0(t))) { + case EVERY: + lab = alclab(2); + loopsp++; + loopsp->ltype = EVERY; + loopsp->nextlab = lab; + loopsp->breaklab = lab + 1; + loopsp->markcount = 1; + emit("mark0"); + traverse(Tree1(t)); + emit("pop"); + if (TType(Tree2(t)) != N_Empty) { /* every e1 do e2 */ + emit("mark0"); + loopsp->ltype = N_Loop; + loopsp->markcount++; + traverse(Tree2(t)); + loopsp->markcount--; + emit("unmark"); + } + else + free(Tree2(t)); + emitlab(loopsp->nextlab); + emit("efail"); + emitlab(loopsp->breaklab); + loopsp--; + break; + + case REPEAT: + lab = alclab(3); + loopsp++; + loopsp->ltype = N_Loop; + loopsp->nextlab = lab + 1; + loopsp->breaklab = lab + 2; + loopsp->markcount = 1; + emitlab(lab); + emitl("mark", lab); + traverse(Tree1(t)); + emitlab(loopsp->nextlab); + emit("unmark"); + emitl("goto", lab); + emitlab(loopsp->breaklab); + loopsp--; + free(Tree2(t)); + break; + + case SUSPEND: /* suspension expression */ + if (creatsp > creatstk) + nfatal(t, "invalid context for suspend", NULL); + lab = alclab(2); + loopsp++; + loopsp->ltype = EVERY; /* like every ... do for next */ + loopsp->nextlab = lab; + loopsp->breaklab = lab + 1; + loopsp->markcount = 1; + emit("mark0"); + traverse(Tree1(t)); + setloc(t); + emit("psusp"); + emit("pop"); + if (TType(Tree2(t)) != N_Empty) { /* suspend e1 do e2 */ + emit("mark0"); + loopsp->ltype = N_Loop; + loopsp->markcount++; + traverse(Tree2(t)); + loopsp->markcount--; + emit("unmark"); + } + else + free(Tree2(t)); + emitlab(loopsp->nextlab); + emit("efail"); + emitlab(loopsp->breaklab); + loopsp--; + break; + + case WHILE: + lab = alclab(3); + loopsp++; + loopsp->ltype = N_Loop; + loopsp->nextlab = lab + 1; + loopsp->breaklab = lab + 2; + loopsp->markcount = 1; + emitlab(lab); + emit("mark0"); + traverse(Tree1(t)); + if (TType(Tree2(t)) != N_Empty) { + emit("unmark"); + emitl("mark", lab); + traverse(Tree2(t)); + } + else + free(Tree2(t)); + emitlab(loopsp->nextlab); + emit("unmark"); + emitl("goto", lab); + emitlab(loopsp->breaklab); + loopsp--; + break; + + case UNTIL: + lab = alclab(4); + loopsp++; + loopsp->ltype = N_Loop; + loopsp->nextlab = lab + 2; + loopsp->breaklab = lab + 3; + loopsp->markcount = 1; + emitlab(lab); + emitl("mark", lab+1); + traverse(Tree1(t)); + emit("unmark"); + emit("efail"); + emitlab(lab+1); + emitl("mark", lab); + traverse(Tree2(t)); + emitlab(loopsp->nextlab); + emit("unmark"); + emitl("goto", lab); + emitlab(loopsp->breaklab); + loopsp--; + break; + } + free(Tree0(t)); + break; + + case N_Next: /* next expression */ + if (loopsp < loopstk || loopsp->nextlab <= 0) + nfatal(t, "invalid context for next", NULL); + else { + if (loopsp->ltype != EVERY && loopsp->markcount > 1) + for (i = 0; i < loopsp->markcount - 1; i++) + emit("unmark"); + emitl("goto", loopsp->nextlab); + } + break; + + case N_Not: /* not expression */ + lab = alclab(1); + emitl("mark", lab); + loopsp->markcount++; + traverse(Tree0(t)); + loopsp->markcount--; + emit("unmark"); + emit("efail"); + emitlab(lab); + emit("pnull"); + break; + + case N_Proc: /* procedure */ + loopsp = loopstk; + loopsp->nextlab = 0; + loopsp->breaklab = 0; + loopsp->markcount = 0; + casesp = casestk; + creatsp = creatstk; + + writecheck(fprintf(codefile, "proc %s\n", Str0(Tree0(t)))); + emitfile(t); + lout(codefile); + constout(codefile); + emit("declend"); + emitline(t); + + if (TType(Tree1(t)) != N_Empty) { + lab = alclab(1); + emitl("init", lab); + emitl("mark", lab); + traverse(Tree1(t)); + emit("unmark"); + emitlab(lab); + } + else + free(Tree1(t)); + if (TType(Tree2(t)) != N_Empty) + traverse(Tree2(t)); + else + free(Tree2(t)); + setloc(Tree3(t)); + emit("pfail"); + emit("end"); + if (!silent) + fprintf(stderr, " %s\n", Str0(Tree0(t))); + free(Tree0(t)); + free(Tree3(t)); + break; + + case N_Real: /* real literal */ + emitn("real", (int)Val0(t)); + break; + + case N_Ret: /* return expression */ + if (creatsp > creatstk) + nfatal(t, "invalid context for return or fail", NULL); + if (Val0(Tree0(t)) == FAIL) + free(Tree1(t)); + else { + lab = alclab(1); + emitl("mark", lab); + loopsp->markcount++; + traverse(Tree1(t)); + loopsp->markcount--; + setloc(t); + emit("pret"); + emitlab(lab); + } + setloc(t); + emit("pfail"); + free(Tree0(t)); + break; + + case N_Scan: /* scanning expression */ + if (Val0(Tree0(t)) == AUGQMARK) + emit("pnull"); + traverse(Tree1(t)); + if (Val0(Tree0(t)) == AUGQMARK) + emit("sdup"); + setloc(t); + emit("bscan"); + traverse(Tree2(t)); + setloc(t); + emit("escan"); + if (Val0(Tree0(t)) == AUGQMARK) + emit("asgn"); + free(Tree0(t)); + break; + + case N_Sect: /* section operation */ + emit("pnull"); + traverse(Tree1(t)); + traverse(Tree2(t)); + if (Val0(Tree0(t)) == PCOLON || Val0(Tree0(t)) == MCOLON) + emit("dup"); + traverse(Tree3(t)); + setloc(Tree0(t)); + if (Val0(Tree0(t)) == PCOLON) + emit("plus"); + else if (Val0(Tree0(t)) == MCOLON) + emit("minus"); + setloc(t); + emit("sect"); + free(Tree0(t)); + break; + + case N_Slist: /* semicolon-separated expr list */ + lab = alclab(1); + emitl("mark", lab); + loopsp->markcount++; + traverse(Tree0(t)); + loopsp->markcount--; + emit("unmark"); + emitlab(lab); + traverse(Tree1(t)); + break; + + case N_Str: /* string literal */ + emitn("str", (int)Val0(t)); + break; + + case N_To: /* to expression */ + emit("pnull"); + traverse(Tree0(t)); + traverse(Tree1(t)); + emit("push1"); + setloc(t); + emit("toby"); + break; + + case N_ToBy: /* to-by expression */ + emit("pnull"); + traverse(Tree0(t)); + traverse(Tree1(t)); + traverse(Tree2(t)); + setloc(t); + emit("toby"); + break; + + case N_Unop: /* unary operator */ + unopa((int)Val0(Tree0(t)),t); + traverse(Tree1(t)); + setloc(t); + unopb((int)Val0(Tree0(t))); + free(Tree0(t)); + break; + + default: + emitn("?????", TType(t)); + tsyserr("traverse: undefined node type"); + } + free(t); + return n; + } + +/* + * binop emits code for binary operators. For non-augmented operators, + * the name of operator is emitted. For augmented operators, an "asgn" + * is emitted after the name of the operator. + */ +static void binop(op) +int op; + { + register int asgn; + register char *name; + + asgn = 0; + switch (op) { + + case ASSIGN: + name = "asgn"; + break; + + case AUGCARET: + asgn++; + case CARET: + name = "power"; + break; + + case AUGCONCAT: + asgn++; + case CONCAT: + name = "cat"; + break; + + case AUGDIFF: + asgn++; + case DIFF: + name = "diff"; + break; + + case AUGEQUIV: + asgn++; + case EQUIV: + name = "eqv"; + break; + + case AUGINTER: + asgn++; + case INTER: + name = "inter"; + break; + + case LBRACK: + name = "subsc"; + break; + + case AUGLCONCAT: + asgn++; + case LCONCAT: + name = "lconcat"; + break; + + case AUGSEQ: + asgn++; + case SEQ: + name = "lexeq"; + break; + + case AUGSGE: + asgn++; + case SGE: + name = "lexge"; + break; + + case AUGSGT: + asgn++; + case SGT: + name = "lexgt"; + break; + + case AUGSLE: + asgn++; + case SLE: + name = "lexle"; + break; + + case AUGSLT: + asgn++; + case SLT: + name = "lexlt"; + break; + + case AUGSNE: + asgn++; + case SNE: + name = "lexne"; + break; + + case AUGMINUS: + asgn++; + case MINUS: + name = "minus"; + break; + + case AUGMOD: + asgn++; + case MOD: + name = "mod"; + break; + + case AUGNEQUIV: + asgn++; + case NEQUIV: + name = "neqv"; + break; + + case AUGNMEQ: + asgn++; + case NMEQ: + name = "numeq"; + break; + + case AUGNMGE: + asgn++; + case NMGE: + name = "numge"; + break; + + case AUGNMGT: + asgn++; + case NMGT: + name = "numgt"; + break; + + case AUGNMLE: + asgn++; + case NMLE: + name = "numle"; + break; + + case AUGNMLT: + asgn++; + case NMLT: + name = "numlt"; + break; + + case AUGNMNE: + asgn++; + case NMNE: + name = "numne"; + break; + + case AUGPLUS: + asgn++; + case PLUS: + name = "plus"; + break; + + case REVASSIGN: + name = "rasgn"; + break; + + case REVSWAP: + name = "rswap"; + break; + + case AUGSLASH: + asgn++; + case SLASH: + name = "div"; + break; + + case AUGSTAR: + asgn++; + case STAR: + name = "mult"; + break; + + case SWAP: + name = "swap"; + break; + + case AUGUNION: + asgn++; + case UNION: + name = "unions"; + break; + + default: + emitn("?binop", op); + tsyserr("binop: undefined binary operator"); + } + emit(name); + if (asgn) + emit("asgn"); + + } +/* + * unopa and unopb handle code emission for unary operators. unary operator + * sequences that are the same as binary operator sequences are recognized + * by the lexical analyzer as binary operators. For example, ~===x means to + * do three tab(match(...)) operations and then a cset complement, but the + * lexical analyzer sees the operator sequence as the "neqv" binary + * operation. unopa and unopb unravel tokens of this form. + * + * When a N_Unop node is encountered, unopa is called to emit the necessary + * number of "pnull" operations to receive the intermediate results. This + * amounts to a pnull for each operation. + */ +static void unopa(op,t) +int op; +nodeptr t; + { + switch (op) { + case NEQUIV: /* unary ~ and three = operators */ + emit("pnull"); + case SNE: /* unary ~ and two = operators */ + case EQUIV: /* three unary = operators */ + emit("pnull"); + case NMNE: /* unary ~ and = operators */ + case UNION: /* two unary + operators */ + case DIFF: /* two unary - operators */ + case SEQ: /* two unary = operators */ + case INTER: /* two unary * operators */ + emit("pnull"); + case BACKSLASH: /* unary \ operator */ + case BANG: /* unary ! operator */ + case CARET: /* unary ^ operator */ + case PLUS: /* unary + operator */ + case TILDE: /* unary ~ operator */ + case MINUS: /* unary - operator */ + case NMEQ: /* unary = operator */ + case STAR: /* unary * operator */ + case QMARK: /* unary ? operator */ + case SLASH: /* unary / operator */ + case DOT: /* unary . operator */ + emit("pnull"); + break; + default: + tsyserr("unopa: undefined unary operator"); + } + } + +/* + * unopb is the back-end code emitter for unary operators. It emits + * the operations represented by the token op. For tokens representing + * a single operator, the name of the operator is emitted. For tokens + * representing a sequence of operators, recursive calls are used. In + * such a case, the operator sequence is "scanned" from right to left + * and unopb is called with the token for the appropriate operation. + * + * For example, consider the sequence of calls and code emission for "~===": + * unopb(NEQUIV) ~=== + * unopb(NMEQ) = + * emits "tabmat" + * unopb(NMEQ) = + * emits "tabmat" + * unopb(NMEQ) = + * emits "tabmat" + * emits "compl" + */ +static void unopb(op) +int op; + { + register char *name; + + switch (op) { + + case DOT: /* unary . operator */ + name = "value"; + break; + + case BACKSLASH: /* unary \ operator */ + name = "nonnull"; + break; + + case BANG: /* unary ! operator */ + name = "bang"; + break; + + case CARET: /* unary ^ operator */ + name = "refresh"; + break; + + case UNION: /* two unary + operators */ + unopb(PLUS); + case PLUS: /* unary + operator */ + name = "number"; + break; + + case NEQUIV: /* unary ~ and three = operators */ + unopb(NMEQ); + case SNE: /* unary ~ and two = operators */ + unopb(NMEQ); + case NMNE: /* unary ~ and = operators */ + unopb(NMEQ); + case TILDE: /* unary ~ operator (cset compl) */ + name = "compl"; + break; + + case DIFF: /* two unary - operators */ + unopb(MINUS); + case MINUS: /* unary - operator */ + name = "neg"; + break; + + case EQUIV: /* three unary = operators */ + unopb(NMEQ); + case SEQ: /* two unary = operators */ + unopb(NMEQ); + case NMEQ: /* unary = operator */ + name = "tabmat"; + break; + + case INTER: /* two unary * operators */ + unopb(STAR); + case STAR: /* unary * operator */ + name = "size"; + break; + + case QMARK: /* unary ? operator */ + name = "random"; + break; + + case SLASH: /* unary / operator */ + name = "null"; + break; + + default: + emitn("?unop", op); + tsyserr("unopb: undefined unary operator"); + } + emit(name); + } + +/* + * emitfile(n) emits "filen" directives for node n's source location. + * emitline(n) emits "line" and possibly "colm" directives. + * setloc(n) does both. + * A directive is only emitted if the corresponding value + * has changed since the previous call. + * + */ +static char *lastfiln = NULL; +static int lastlin = 0; + +static void setloc(n) +nodeptr n; + { + emitfile(n); + emitline(n); + } + +static void emitfile(n) +nodeptr n; + { + if ((n != NULL) && + (TType(n) != N_Empty) && + (File(n) != NULL) && + (lastfiln == NULL || strcmp(File(n), lastfiln) != 0)) { + lastfiln = File(n); + emits("filen", lastfiln); + } + } + +static void emitline(n) +nodeptr n; + { + #ifdef SrcColumnInfo + /* + * if either line or column has changed, emit location information + */ + if (((Col(n) << 16) + Line(n)) != lastlin) { + lastlin = (Col(n) << 16) + Line(n); + emitn("line",Line(n)); + emitn("colm",Col(n)); + } + #else /* SrcColumnInfo */ + /* + * if line has changed, emit line information + */ + if (Line(n) != lastlin) { + lastlin = Line(n); + emitn("line", lastlin); + } + #endif /* SrcColumnInfo */ + } + +/* + * The emit* routines output ucode to codefile. The various routines are: + * + * emitlab(l) - emit "lab" instruction for label l. + * emit(s) - emit instruction s. + * emitl(s,a) - emit instruction s with reference to label a. + * emitn(s,n) - emit instruction s with numeric argument a. + * emits(s,a) - emit instruction s with string argument a. + */ +static void emitlab(l) +int l; + { + writecheck(fprintf(codefile, "lab L%d\n", l)); + } + +static void emit(s) +char *s; + { + writecheck(fprintf(codefile, "\t%s\n", s)); + } + +static void emitl(s, a) +char *s; +int a; + { + writecheck(fprintf(codefile, "\t%s\tL%d\n", s, a)); + } + +static void emitn(s, a) +char *s; +int a; + { + writecheck(fprintf(codefile, "\t%s\t%d\n", s, a)); + } + +static void emits(s, a) +char *s, *a; + { + writecheck(fprintf(codefile, "\t%s\t%s\n", s, a)); + } + +/* + * alclab allocates n labels and returns the first. For the interpreter, + * labels are restarted at 1 for each procedure, while in the compiler, + * they start at 1 and increase throughout the entire compilation. + */ +static int alclab(n) +int n; + { + register int lab; + + lab = nextlab; + nextlab += n; + return lab; + } diff --git a/src/icont/tglobals.c b/src/icont/tglobals.c new file mode 100644 index 0000000..0e963ea --- /dev/null +++ b/src/icont/tglobals.c @@ -0,0 +1,24 @@ +/* + * tglobals.c - declaration and initialization of icont globals. + */ + +#include "../h/gsupport.h" +#include "tproto.h" + +#define Global +#define Init(v) = v +#include "tglobals.h" /* define globals */ + +/* + * Initialize globals that cannot be handled statically. + */ +void initglob(void) { + /* + * Round hash table sizes to next power of two, and set masks for hashing. + */ + lchsize = round2(lchsize); cmask = lchsize - 1; + fhsize = round2(fhsize); fmask = fhsize - 1; + ghsize = round2(ghsize); gmask = ghsize - 1; + ihsize = round2(ihsize); imask = ihsize - 1; + lhsize = round2(lhsize); lmask = lhsize - 1; + } diff --git a/src/icont/tglobals.h b/src/icont/tglobals.h new file mode 100644 index 0000000..5568293 --- /dev/null +++ b/src/icont/tglobals.h @@ -0,0 +1,67 @@ +/* + * Global variables. + */ + +#ifndef Global + #define Global extern + #define Init(v) +#endif /* Global */ + +/* + * Masks for accessing hash tables. + */ +Global int cmask; /* mask for constant table hash */ +Global int fmask; /* mask for field table hash */ +Global int gmask; /* mask for global table hash */ +Global int imask; /* mask for identifier table hash */ +Global int lmask; /* mask for local table hash */ + +/* + * Array sizes for various linker tables that can be expanded with realloc(). + */ +Global unsigned int csize Init(100); /* constant table */ +Global unsigned int lsize Init(100); /* local table */ +Global unsigned int nsize Init(1000); /* ipc/line num. assoc. table */ +Global unsigned int stsize Init(20000); /* string space */ +Global unsigned int maxcode Init(15000); /* code space */ +Global unsigned int fnmsize Init(10); /* ipc/file name assoc. table */ +Global unsigned int maxlabels Init(500); /* maximum num of labels/proc */ + +/* + * Sizes of various hash tables. + */ +Global unsigned int lchsize Init(128); /* constant hash table */ +Global unsigned int fhsize Init(32); /* field hash table */ +Global unsigned int ghsize Init(128); /* global hash table */ +Global unsigned int ihsize Init(128); /* identifier hash table */ +Global unsigned int lhsize Init(128); /* local hash table */ + +/* + * Variables related to command processing. + */ +Global char *progname Init("icont"); /* program name for diagnostics */ +Global int silent Init(0); /* -s: suppress info messages? */ +Global int m4pre Init(0); /* -m: use m4 preprocessor? */ +Global int uwarn Init(0); /* -u: warn about undefined ids? */ +Global int trace Init(0); /* -t: initial &trace value */ +Global int pponly Init(0); /* -E: preprocess only */ +Global int strinv Init(0); /* -f s: allow full string invocation */ +Global int verbose Init(1); /* -v n: verbosity of commentary */ + +#ifdef DeBugLinker + Global int Dflag Init(0); /* -L: linker debug (write .ux file) */ +#endif /* DeBugLinker */ + +/* + * Files and related globals. + */ +Global char *lpath; /* search path for $include */ +Global char *ipath; /* search path for linking */ + +Global FILE *codefile Init(0); /* current ucode output file */ +Global FILE *globfile Init(0); /* current global table output file */ + +Global char *ofile Init(NULL); /* name of linker output file */ + +Global char *iconxloc; /* path to iconx */ +Global long hdrsize; /* size of iconx header */ diff --git a/src/icont/tgrammar.c b/src/icont/tgrammar.c new file mode 100644 index 0000000..7301c07 --- /dev/null +++ b/src/icont/tgrammar.c @@ -0,0 +1,239 @@ +/* + * tgrammar.c - includes and macros for building the parse tree + */ + +#include "../h/define.h" +#include "../common/yacctok.h" + +%{ +/* + * These commented directives are passed through the first application + * of cpp, then turned into real includes in tgram.g by fixgram.icn. + */ +/*#include "../h/gsupport.h"*/ +/*#include "../h/lexdef.h"*/ +/*#include "tproto.h"*/ +/*#include "tglobals.h"*/ +/*#include "tsym.h"*/ +/*#include "tree.h"*/ +/*#include "keyword.h"*/ +/*#undef YYSTYPE*/ +/*#define YYSTYPE nodeptr*/ +/*#define YYMAXDEPTH 500*/ + +extern int fncargs[]; +int idflag; +int id_cnt; + +#define EmptyNode tree1(N_Empty) + +#define Alt(x1,x2,x3) $$ = tree4(N_Alt,x2,x1,x3) +#define Apply(x1,x2,x3) $$ = tree4(N_Apply,x2,x1,x3) +#define Arglist1() id_cnt = 0 +#define Arglist2(x) /* empty */ +#define Arglist3(x,y,z) id_cnt = -id_cnt +#define Bact(x1,x2,x3) $$ = tree5(N_Activat,x2,x2,x3,x1) +#define Bamper(x1,x2,x3) $$ = tree5(N_Conj,x2,x2,x1,x3) +#define Bassgn(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Baugact(x1,x2,x3) $$ = tree5(N_Activat,x2,x2,x3,x1) +#define Baugamper(x1,x2,x3) $$ = tree5(N_Conj,x2,x2,x1,x3) +#define Baugcat(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Baugeq(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Baugeqv(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Baugge(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Bauggt(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Bauglcat(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Baugle(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Bauglt(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Baugne(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Baugneqv(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Baugques(x1,x2,x3) $$ = tree5(N_Scan,x2,x2,x1,x3) +#define Baugseq(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Baugsge(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Baugsgt(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Baugsle(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Baugslt(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Baugsne(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Bcaret(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bcareta(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Bcat(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bdiff(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bdiffa(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Beq(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Beqv(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bge(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bgt(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Binter(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bintera(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Blcat(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Ble(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Blim(x1,x2,x3) $$ = tree4(N_Limit,x1,x1,x3) +#define Blt(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bminus(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bminusa(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Bmod(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bmoda(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Bne(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bneqv(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bplus(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bplusa(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Bques(x1,x2,x3) $$ = tree5(N_Scan,x2,x2,x1,x3) +#define Brace(x1,x2,x3) $$ = x2 +#define Brack(x1,x2,x3) $$ = tree3(N_List,x1,x2) +#define Brassgn(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Break(x1,x2) $$ = tree3(N_Break,x1,x2) +#define Brswap(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bseq(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bsge(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bsgt(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bslash(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bslasha(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Bsle(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bslt(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bsne(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bstar(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bstara(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Bswap(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Bunion(x1,x2,x3) $$ = tree5(N_Binop,x2,x2,x1,x3) +#define Buniona(x1,x2,x3) $$ = tree5(N_Augop,x2,x2,x1,x3) +#define Call(x1,x2,x3,x4) if (Val2(x1) = blocate(Str0(x1))) {\ + Val4(x1) = fncargs[Val2(x1)-1]; \ + $$ = tree4(N_Call,x2,x1,x3);} \ + else { \ + Val0(x1) = putloc(Str0(x1),0); \ + $$ = tree4(N_Invok,x2,x1,x3); \ + } +#define Case(x1,x2,x3,x4,x5,x6) $$ = tree4(N_Case,x1,x2,x5) +#define Caselist(x1,x2,x3) $$ = tree4(N_Clist,x2,x1,x3) +#define Cclause0(x1,x2,x3) $$ = tree4(N_Ccls,x2,x1,x3) +#define Cclause1(x1,x2,x3) $$ = tree4(N_Ccls,x2,x1,x3) +#define Cliter(x) Val0(x) = putlit(Str0(x),F_CsetLit,(int)Val1(x)) +#define Colon(x) $$ = x +#define Compound(x1,x2,x3) $$ = tree4(N_Slist,x2,x1,x3) +#define Create(x1,x2) $$ = tree3(N_Create,x1,x2) +#define Elst0(x1) /* empty */ +#define Elst1(x1,x2,x3) $$ = tree4(N_Elist,x2,x1,x3) +#define Every0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) +#define Every1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) +#define Fail(x) $$ = tree4(N_Ret,x,x,EmptyNode) +#define Field(x1,x2,x3) $$ = tree4(N_Field,x2,x1,x3) +#define Global0(x) idflag = F_Global +#define Global1(x1,x2,x3) /* empty */ +#define Globdcl(x) /* empty */ +#define Ident(x) install(Str0(x),idflag,0);\ + id_cnt = 1 +#define Idlist(x1,x2,x3) install(Str0(x3),idflag,0);\ + ++id_cnt +#define If0(x1,x2,x3,x4) $$ = tree5(N_If,x1,x2,x4,EmptyNode) +#define If1(x1,x2,x3,x4,x5,x6) $$ = tree5(N_If,x1,x2,x4,x6) +#define Iliter(x) Val0(x) = putlit(Str0(x),F_IntLit,0) +#define Initial1() $$ = EmptyNode +#define Initial2(x1,x2,x3) $$ = x2 +#define Invocable(x1,x2) /* empty */ +#define Invocdcl(x1) /* empty */ +#define Invoclist(x1,x2,x3) /* empty */ +#define Invocop1(x1) addinvk(Str0(x1),1) +#define Invocop2(x1) addinvk(Str0(x1),2) +#define Invocop3(x1,x2,x3) addinvk(Str0(x1),3) +#define Invoke(x1,x2,x3,x4) $$ = tree4(N_Invok,x2,x1,x3) +#define Keyword(x1,x2) if (klookup(Str0(x2)) == 0)\ + tfatal("invalid keyword",Str0(x2));\ + $$ = c_str_leaf(N_Key,x1,Str0(x2)) +#define Kfail(x1,x2) $$ = c_str_leaf(N_Key,x1,"fail") +#define Link(x1,x2) /* empty */ +#define Linkdcl(x) /* empty */ +#define Lnkfile1(x) addlfile(Str0(x)) +#define Lnkfile2(x) addlfile(Str0(x)) +#define Lnklist(x1,x2,x3) /* empty */ +#define Local(x) idflag = F_Dynamic +#define Locals1() /* empty */ +#define Locals2(x1,x2,x3,x4) /* empty */ +#define Mcolon(x) $$ = x +#define Nexpr() $$ = EmptyNode +#define Next(x) $$ = tree2(N_Next,x) +#define Paren(x1,x2,x3) if ((x2)->n_type == N_Elist)\ + $$ = tree4(N_Invok,x1,EmptyNode,x2);\ + else\ + $$ = x2 +#define Pcolon(x) $$ = x +#define Pdco0(x1,x2,x3) $$ = tree4(N_Invok,x2,x1,\ + tree3(N_List,x2,EmptyNode)) +#define Pdco1(x1,x2,x3,x4) $$ = tree4(N_Invok,x2,x1,tree3(N_List,x2,x3)) +#define Pdcolist0(x) $$ = tree3(N_Create,x,x) +#define Pdcolist1(x1,x2,x3) $$ = tree4(N_Elist,x2,x1,tree3(N_Create,x2,x3)) +#define Proc1(x1,x2,x3,x4,x5,x6) $$ = tree6(N_Proc,x1,x1,x4,x5,x6) +#define Procbody1() $$ = EmptyNode +#define Procbody2(x1,x2,x3) $$ = tree4(N_Slist,x2,x1,x3) +#define Procdcl(x) if (!nocode)\ + codegen(x);\ + nocode = 0;\ + loc_init() +#define Prochead1(x1,x2) idflag = F_Argument +#define Prochead2(x1,x2,x3,x4,x5,x6)\ + $$ = x2;\ + install(Str0(x2),F_Proc|F_Global,id_cnt) +#define Progend(x1,x2) gout(globfile) +#define Recdcl(x) if (!nocode)\ + rout(globfile, Str0(x));\ + nocode = 0;\ + loc_init() +#define Record1(x1,x2) idflag = F_Argument +#define Record2(x1,x2,x3,x4,x5,x6) install(Str0(x2),F_Record|F_Global,id_cnt); \ + $$ = x2 +#define Repeat(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) +#define Return(x1,x2) $$ = tree4(N_Ret,x1,x1,x2) +#define Rliter(x) Val0(x) = putlit(Str0(x),F_RealLit,0) +#define Section(x1,x2,x3,x4,x5,x6) $$ = tree6(N_Sect,x4,x4,x1,x3,x5) +#define Sliter(x) Val0(x) = putlit(Str0(x),F_StrLit,(int)Val1(x)) +#define Static(x) idflag = F_Static +#define Subscript(x1,x2,x3,x4) $$ = buildarray(x1,x2,x3,x4) +#define Suspend0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) +#define Suspend1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) +#define To0(x1,x2,x3) $$ = tree4(N_To,x2,x1,x3) +#define To1(x1,x2,x3,x4,x5) $$ = tree5(N_ToBy,x2,x1,x3,x5) +#define Uat(x1,x2) $$ = tree5(N_Activat,x1,x1,x2,EmptyNode) +#define Ubackslash(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Ubang(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Ubar(x1,x2) $$ = tree3(N_Bar,x2,x2) +#define Ucaret(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Uconcat(x1,x2) $$ = tree3(N_Bar,x2,x2) +#define Udiff(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Udot(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Uequiv(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Uinter(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Ulconcat(x1,x2) $$ = tree3(N_Bar,x2,x2) +#define Ulexeq(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Ulexne(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Uminus(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Unot(x1,x2) $$ = tree3(N_Not,x2,x2) +#define Unotequiv(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Until0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) +#define Until1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) +#define Unumeq(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Unumne(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Uplus(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Uqmark(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Uslash(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Ustar(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Utilde(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Uunion(x1,x2) $$ = tree4(N_Unop,x1,x1,x2) +#define Var(x) Val0(x) = putloc(Str0(x),0) +#define While0(x1,x2) $$ = tree5(N_Loop,x1,x1,x2,EmptyNode) +#define While1(x1,x2,x3,x4) $$ = tree5(N_Loop,x1,x1,x2,x4) +%} + +%% +#include "../h/grammar.h" +%% + +/* + * xfree(p) -- used with free(p) macro to avoid compiler errors from + * miscast free calls generated by Yacc. + */ +static void xfree(p) +char *p; +{ + free(p); +} + +/*#define free(p) xfree((char*)p)*/ diff --git a/src/icont/tlex.c b/src/icont/tlex.c new file mode 100644 index 0000000..d79bcc9 --- /dev/null +++ b/src/icont/tlex.c @@ -0,0 +1,16 @@ +/* + * tlex.c -- the lexical analyzer for icont. + */ + +#include "../h/gsupport.h" +#undef T_Real +#undef T_String +#undef T_Cset +#include "../h/lexdef.h" +#include "ttoken.h" +#include "tree.h" +#include "tproto.h" +#include "../h/parserr.h" +#include "../common/lextab.h" +#include "../common/yylex.h" +#include "../common/error.h" diff --git a/src/icont/tmem.c b/src/icont/tmem.c new file mode 100644 index 0000000..54e1b60 --- /dev/null +++ b/src/icont/tmem.c @@ -0,0 +1,76 @@ +/* + * tmem.c -- memory initialization and allocation for the translator. + */ + +#include "../h/gsupport.h" +#include "tproto.h" +#include "tglobals.h" +#include "tsym.h" +#include "tree.h" + +struct tlentry **lhash; /* hash area for local table */ +struct tgentry **ghash; /* hash area for global table */ +struct tcentry **chash; /* hash area for constant table */ + +struct tlentry *lfirst; /* first local table entry */ +struct tlentry *llast; /* last local table entry */ +struct tcentry *cfirst; /* first constant table entry */ +struct tcentry *clast; /* last constant table entry */ +struct tgentry *gfirst; /* first global table entry */ +struct tgentry *glast; /* last global table entry */ + +extern struct str_buf lex_sbuf; + + +/* + * tmalloc - allocate memory for the translator + */ + +void tmalloc() +{ + chash = (struct tcentry **) tcalloc(lchsize, sizeof (struct tcentry *)); + ghash = (struct tgentry **) tcalloc(ghsize, sizeof (struct tgentry *)); + lhash = (struct tlentry **) tcalloc(lhsize, sizeof (struct tlentry *)); + init_str(); + init_sbuf(&lex_sbuf); + } + +/* + * meminit - clear tables for use in translating the next file + */ +void tminit() + { + register struct tlentry **lp; + register struct tgentry **gp; + register struct tcentry **cp; + + lfirst = NULL; + llast = NULL; + cfirst = NULL; + clast = NULL; + gfirst = NULL; + glast = NULL; + + /* + * Zero out the hash tables. + */ + for (lp = lhash; lp < &lhash[lhsize]; lp++) + *lp = NULL; + for (gp = ghash; gp < &ghash[ghsize]; gp++) + *gp = NULL; + for (cp = chash; cp < &chash[lchsize]; cp++) + *cp = NULL; + } + +/* + * tmfree - free memory used by the translator + */ +void tmfree() + { + free((char *) chash); chash = NULL; + free((char *) ghash); ghash = NULL; + free((char *) lhash); lhash = NULL; + + free_stbl(); /* free string table */ + clear_sbuf(&lex_sbuf); /* free buffer store for strings */ + } diff --git a/src/icont/tparse.c b/src/icont/tparse.c new file mode 100644 index 0000000..35420fb --- /dev/null +++ b/src/icont/tparse.c @@ -0,0 +1,1917 @@ +# define IDENT 257 +# define INTLIT 258 +# define REALLIT 259 +# define STRINGLIT 260 +# define CSETLIT 261 +# define EOFX 262 +# define BREAK 263 +# define BY 264 +# define CASE 265 +# define CREATE 266 +# define DEFAULT 267 +# define DO 268 +# define ELSE 269 +# define END 270 +# define EVERY 271 +# define FAIL 272 +# define GLOBAL 273 +# define IF 274 +# define INITIAL 275 +# define INVOCABLE 276 +# define LINK 277 +# define LOCAL 278 +# define NEXT 279 +# define NOT 280 +# define OF 281 +# define PROCEDURE 282 +# define RECORD 283 +# define REPEAT 284 +# define RETURN 285 +# define STATIC 286 +# define SUSPEND 287 +# define THEN 288 +# define TO 289 +# define UNTIL 290 +# define WHILE 291 +# define BANG 292 +# define MOD 293 +# define AUGMOD 294 +# define AND 295 +# define AUGAND 296 +# define STAR 297 +# define AUGSTAR 298 +# define INTER 299 +# define AUGINTER 300 +# define PLUS 301 +# define AUGPLUS 302 +# define UNION 303 +# define AUGUNION 304 +# define MINUS 305 +# define AUGMINUS 306 +# define DIFF 307 +# define AUGDIFF 308 +# define DOT 309 +# define SLASH 310 +# define AUGSLASH 311 +# define ASSIGN 312 +# define SWAP 313 +# define NMLT 314 +# define AUGNMLT 315 +# define REVASSIGN 316 +# define REVSWAP 317 +# define SLT 318 +# define AUGSLT 319 +# define SLE 320 +# define AUGSLE 321 +# define NMLE 322 +# define AUGNMLE 323 +# define NMEQ 324 +# define AUGNMEQ 325 +# define SEQ 326 +# define AUGSEQ 327 +# define EQUIV 328 +# define AUGEQUIV 329 +# define NMGT 330 +# define AUGNMGT 331 +# define NMGE 332 +# define AUGNMGE 333 +# define SGT 334 +# define AUGSGT 335 +# define SGE 336 +# define AUGSGE 337 +# define QMARK 338 +# define AUGQMARK 339 +# define AT 340 +# define AUGAT 341 +# define BACKSLASH 342 +# define CARET 343 +# define AUGCARET 344 +# define BAR 345 +# define CONCAT 346 +# define AUGCONCAT 347 +# define LCONCAT 348 +# define AUGLCONCAT 349 +# define TILDE 350 +# define NMNE 351 +# define AUGNMNE 352 +# define SNE 353 +# define AUGSNE 354 +# define NEQUIV 355 +# define AUGNEQUIV 356 +# define LPAREN 357 +# define RPAREN 358 +# define PCOLON 359 +# define COMMA 360 +# define MCOLON 361 +# define COLON 362 +# define SEMICOL 363 +# define LBRACK 364 +# define RBRACK 365 +# define LBRACE 366 +# define RBRACE 367 + +# line 145 "tgram.g" +/* + * These commented directives are passed through the first application + * of cpp, then turned into real includes in tgram.g by fixgram.icn. + */ +#include "../h/gsupport.h" +#undef T_Real +#undef T_String +#undef T_Cset +#include "../h/lexdef.h" +#include "tproto.h" +#include "tglobals.h" +#include "tsym.h" +#include "tree.h" +#include "keyword.h" +#undef YYSTYPE +#define YYSTYPE nodeptr +#define YYMAXDEPTH 500 + +extern int fncargs[]; +int idflag; +int id_cnt; + + + +#define yyclearin yychar = -1 +#define yyerrok yyerrflag = 0 +extern int yychar; +extern int yyerrflag; +#ifndef YYMAXDEPTH +#define YYMAXDEPTH 150 +#endif +#ifndef YYSTYPE +#define YYSTYPE int +#endif +YYSTYPE yylval, yyval; +# define YYERRCODE 256 + +# line 442 "tgram.g" + + +/* + * xfree(p) -- used with free(p) macro to avoid compiler errors from + * miscast free calls generated by Yacc. + */ +static void xfree(p) +char *p; +{ + free(p); +} + +#define free(p) xfree((char*)p) +int yyexca[] ={ +-1, 0, + 262, 2, + 273, 2, + 276, 2, + 277, 2, + 282, 2, + 283, 2, + -2, 0, +-1, 1, + 0, -1, + -2, 0, +-1, 20, + 270, 40, + 363, 42, + -2, 0, +-1, 86, + 264, 42, + 268, 42, + 269, 42, + 281, 42, + 288, 42, + 289, 42, + 293, 42, + 294, 42, + 296, 42, + 298, 42, + 300, 42, + 302, 42, + 304, 42, + 306, 42, + 308, 42, + 311, 42, + 312, 42, + 313, 42, + 314, 42, + 315, 42, + 316, 42, + 317, 42, + 318, 42, + 319, 42, + 320, 42, + 321, 42, + 322, 42, + 323, 42, + 325, 42, + 327, 42, + 329, 42, + 330, 42, + 331, 42, + 332, 42, + 333, 42, + 334, 42, + 335, 42, + 336, 42, + 337, 42, + 339, 42, + 341, 42, + 344, 42, + 347, 42, + 349, 42, + 352, 42, + 354, 42, + 356, 42, + 358, 42, + 359, 42, + 360, 42, + 361, 42, + 362, 42, + 363, 42, + 365, 42, + 367, 42, + -2, 0, +-1, 87, + 358, 42, + 360, 42, + -2, 0, +-1, 88, + 363, 42, + 367, 42, + -2, 0, +-1, 89, + 360, 42, + 365, 42, + -2, 0, +-1, 96, + 264, 42, + 268, 42, + 269, 42, + 281, 42, + 288, 42, + 289, 42, + 293, 42, + 294, 42, + 296, 42, + 298, 42, + 300, 42, + 302, 42, + 304, 42, + 306, 42, + 308, 42, + 311, 42, + 312, 42, + 313, 42, + 314, 42, + 315, 42, + 316, 42, + 317, 42, + 318, 42, + 319, 42, + 320, 42, + 321, 42, + 322, 42, + 323, 42, + 325, 42, + 327, 42, + 329, 42, + 330, 42, + 331, 42, + 332, 42, + 333, 42, + 334, 42, + 335, 42, + 336, 42, + 337, 42, + 339, 42, + 341, 42, + 344, 42, + 347, 42, + 349, 42, + 352, 42, + 354, 42, + 356, 42, + 358, 42, + 359, 42, + 360, 42, + 361, 42, + 362, 42, + 363, 42, + 365, 42, + 367, 42, + -2, 0, +-1, 97, + 264, 42, + 268, 42, + 269, 42, + 281, 42, + 288, 42, + 289, 42, + 293, 42, + 294, 42, + 296, 42, + 298, 42, + 300, 42, + 302, 42, + 304, 42, + 306, 42, + 308, 42, + 311, 42, + 312, 42, + 313, 42, + 314, 42, + 315, 42, + 316, 42, + 317, 42, + 318, 42, + 319, 42, + 320, 42, + 321, 42, + 322, 42, + 323, 42, + 325, 42, + 327, 42, + 329, 42, + 330, 42, + 331, 42, + 332, 42, + 333, 42, + 334, 42, + 335, 42, + 336, 42, + 337, 42, + 339, 42, + 341, 42, + 344, 42, + 347, 42, + 349, 42, + 352, 42, + 354, 42, + 356, 42, + 358, 42, + 359, 42, + 360, 42, + 361, 42, + 362, 42, + 363, 42, + 365, 42, + 367, 42, + -2, 0, +-1, 111, + 270, 40, + 363, 42, + -2, 0, +-1, 117, + 270, 40, + 363, 42, + -2, 0, +-1, 182, + 360, 42, + 365, 42, + -2, 0, +-1, 183, + 360, 42, + -2, 0, +-1, 184, + 358, 42, + 360, 42, + -2, 0, +-1, 311, + 358, 42, + 360, 42, + 365, 42, + -2, 0, +-1, 313, + 363, 42, + 367, 42, + -2, 0, +-1, 335, + 360, 42, + 367, 42, + -2, 0, + }; +# define YYNPROD 203 +# define YYLAST 728 +int yyact[]={ + + 38, 84, 91, 92, 93, 94, 312, 86, 185, 99, + 83, 118, 335, 359, 341, 102, 95, 358, 98, 334, + 311, 311, 355, 85, 51, 329, 314, 20, 103, 96, + 118, 97, 313, 228, 101, 100, 56, 346, 118, 90, + 118, 59, 117, 62, 360, 58, 108, 70, 336, 64, + 311, 57, 228, 55, 60, 326, 184, 228, 310, 119, + 311, 107, 106, 182, 345, 183, 324, 232, 65, 110, + 67, 168, 69, 169, 352, 214, 118, 350, 328, 177, + 41, 356, 71, 174, 50, 175, 73, 61, 325, 52, + 53, 320, 54, 316, 63, 66, 176, 68, 327, 72, + 118, 87, 332, 118, 333, 331, 319, 361, 89, 116, + 88, 305, 38, 84, 91, 92, 93, 94, 118, 86, + 181, 99, 83, 353, 317, 231, 3, 102, 95, 218, + 98, 318, 105, 118, 19, 85, 51, 315, 118, 28, + 103, 96, 29, 97, 217, 321, 101, 100, 56, 309, + 170, 90, 172, 59, 173, 62, 171, 58, 118, 70, + 30, 64, 18, 57, 118, 55, 60, 44, 180, 37, + 179, 178, 113, 24, 104, 114, 25, 330, 351, 306, + 65, 212, 67, 115, 69, 82, 2, 81, 80, 27, + 17, 36, 23, 79, 71, 78, 50, 77, 73, 61, + 76, 52, 53, 75, 54, 74, 63, 66, 49, 68, + 47, 72, 42, 87, 38, 84, 91, 92, 93, 94, + 89, 86, 88, 99, 83, 40, 112, 322, 109, 102, + 95, 34, 98, 273, 274, 111, 33, 85, 51, 12, + 233, 32, 103, 96, 21, 97, 22, 26, 101, 100, + 56, 10, 9, 90, 8, 59, 7, 62, 31, 58, + 6, 70, 5, 64, 1, 57, 0, 55, 60, 13, + 0, 216, 15, 14, 0, 210, 0, 0, 16, 11, + 0, 0, 65, 0, 67, 234, 69, 236, 239, 221, + 222, 223, 224, 225, 226, 227, 71, 230, 50, 229, + 73, 61, 0, 52, 53, 237, 54, 0, 63, 66, + 0, 68, 0, 72, 0, 87, 46, 84, 91, 92, + 93, 94, 89, 86, 88, 99, 83, 45, 0, 0, + 0, 102, 95, 0, 98, 0, 289, 290, 0, 85, + 51, 0, 0, 235, 103, 96, 0, 97, 0, 238, + 101, 100, 56, 0, 0, 90, 0, 59, 0, 62, + 0, 58, 4, 70, 303, 64, 308, 57, 0, 55, + 60, 0, 0, 13, 304, 0, 15, 14, 0, 0, + 0, 0, 16, 11, 65, 0, 67, 0, 69, 338, + 0, 213, 0, 0, 0, 0, 0, 0, 71, 43, + 50, 0, 73, 61, 0, 52, 53, 323, 54, 347, + 63, 66, 35, 68, 152, 72, 0, 87, 0, 133, + 0, 150, 0, 130, 89, 131, 88, 128, 0, 127, + 0, 129, 0, 126, 362, 0, 132, 121, 120, 0, + 140, 123, 122, 0, 147, 164, 146, 0, 139, 158, + 135, 157, 143, 163, 136, 160, 138, 154, 137, 166, + 145, 162, 144, 161, 149, 156, 151, 155, 0, 134, + 0, 0, 124, 0, 125, 0, 153, 141, 211, 148, + 215, 142, 165, 39, 159, 0, 167, 0, 219, 220, + 0, 295, 296, 297, 298, 299, 0, 0, 291, 292, + 293, 294, 0, 35, 0, 0, 0, 339, 340, 35, + 342, 343, 344, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 348, 0, 0, 0, 48, 0, 0, 0, + 0, 0, 0, 354, 0, 0, 0, 0, 0, 0, + 0, 0, 357, 0, 0, 0, 0, 0, 0, 0, + 0, 354, 363, 364, 275, 276, 277, 278, 279, 280, + 281, 282, 283, 284, 285, 286, 287, 288, 0, 0, + 0, 0, 0, 0, 0, 307, 0, 186, 187, 188, + 189, 190, 191, 192, 193, 194, 195, 196, 197, 198, + 199, 200, 201, 202, 203, 204, 205, 206, 207, 208, + 209, 0, 0, 240, 241, 242, 243, 244, 245, 246, + 247, 248, 249, 250, 251, 252, 253, 254, 255, 256, + 257, 258, 259, 260, 261, 262, 263, 264, 265, 266, + 267, 268, 269, 270, 271, 272, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 337, 0, 215, 300, 301, 302, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 349 }; +int yypact[]={ + + -130, -1000, 100, -1000, -1000, -1000, -1000, -1000, -1000, -1000, + -1000, -95, -229, -1000, -84, -118, -97, -4, -1000, -1000, + -42, -125, -298, -1000, -1000, -1000, -299, -1000, -1000, -316, + -1000, -1000, -288, -103, -161, -321, -219, -279, -1000, -1000, + 125, -1000, 131, -275, -151, -214, -1000, -172, -1000, -301, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, -1000, -1000, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -42, -1000, -1000, -42, -42, -42, -42, + -128, -1000, -1000, -1000, -1000, -1000, -42, -42, -42, -42, + -42, -42, -42, -42, -303, -1000, -84, -118, -133, -290, + -125, -42, -125, -42, -1000, -1000, -1000, -42, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, 60, 60, 60, 60, 60, 60, 60, 60, + 60, 60, -42, -256, -42, -108, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, + -219, -1000, -300, -1000, -361, -331, -339, -1000, -1000, -1000, + -1000, -131, -195, -157, -137, -162, -177, -219, -112, -1000, + -1000, -1000, -125, -292, -303, -182, -308, -265, -1000, -279, + -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -186, -1000, -275, -275, -275, -275, -275, + -275, -275, -275, -275, -275, -275, -275, -275, -275, -151, + -151, -214, -214, -214, -214, -1000, -1000, -1000, -1000, -1000, + -1000, -1000, -1000, -340, -257, -1000, -348, -1000, -310, -1000, + -1000, -42, -1000, -42, -1000, -42, -42, -352, -42, -42, + -42, -1000, -294, -327, -1000, -1000, -1000, -1000, 60, -1000, + -42, -1000, -1000, -1000, -1000, -42, -1000, -1000, -1000, -219, + -192, -144, -219, -219, -219, -1000, -343, -1000, -284, -1000, + -42, -350, -1000, -318, -255, -1000, -1000, -219, -1000, -144, + -42, -42, -1000, -219, -219 }; +int yypgo[]={ + + 0, 264, 186, 262, 260, 256, 254, 252, 251, 247, + 189, 246, 192, 244, 174, 241, 240, 239, 236, 235, + 231, 228, 227, 226, 191, 391, 169, 483, 225, 80, + 212, 399, 167, 327, 316, 210, 526, 208, 205, 203, + 200, 197, 195, 193, 188, 187, 185, 181, 75, 179, + 178, 74, 177 }; +int yyr1[]={ + + 0, 1, 2, 2, 3, 3, 3, 3, 3, 8, + 9, 9, 10, 10, 10, 7, 11, 11, 12, 12, + 13, 6, 15, 4, 16, 16, 5, 21, 17, 22, + 22, 22, 14, 14, 18, 18, 23, 23, 19, 19, + 20, 20, 25, 25, 24, 24, 26, 26, 27, 27, + 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, + 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, + 27, 27, 27, 27, 27, 27, 27, 27, 27, 27, + 27, 28, 28, 28, 29, 29, 30, 30, 30, 30, + 30, 30, 30, 30, 30, 30, 30, 30, 30, 30, + 30, 31, 31, 31, 32, 32, 32, 32, 32, 33, + 33, 33, 33, 33, 34, 34, 35, 35, 35, 35, + 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, + 36, 36, 36, 36, 36, 36, 36, 36, 36, 36, + 36, 36, 36, 36, 36, 37, 37, 37, 37, 37, + 37, 37, 37, 37, 37, 37, 37, 37, 37, 37, + 37, 37, 37, 37, 37, 37, 37, 37, 43, 43, + 44, 44, 45, 45, 46, 40, 40, 40, 40, 41, + 41, 42, 50, 50, 51, 51, 47, 47, 49, 49, + 38, 38, 38, 38, 39, 52, 52, 52, 48, 48, + 1, 5, 24 }; +int yyr2[]={ + + 0, 5, 0, 4, 3, 3, 3, 3, 3, 5, + 2, 7, 3, 3, 7, 5, 2, 7, 3, 3, + 1, 7, 1, 13, 1, 3, 13, 1, 13, 1, + 3, 7, 3, 7, 1, 9, 3, 3, 1, 7, + 1, 7, 1, 2, 2, 7, 2, 7, 2, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 2, 7, 11, 2, 7, 2, 7, 7, 7, + 7, 7, 7, 7, 7, 7, 7, 7, 7, 7, + 7, 2, 7, 7, 2, 7, 7, 7, 7, 2, + 7, 7, 7, 7, 2, 7, 2, 7, 7, 7, + 2, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 5, 5, 5, 5, 5, + 5, 5, 5, 5, 5, 2, 2, 2, 2, 2, + 2, 2, 2, 2, 5, 3, 3, 5, 7, 7, + 7, 9, 7, 9, 9, 7, 5, 5, 5, 9, + 5, 9, 5, 9, 5, 3, 5, 5, 9, 9, + 13, 13, 2, 7, 7, 7, 3, 7, 3, 7, + 3, 3, 3, 3, 13, 3, 3, 3, 2, 7, + 6, 8, 2 }; +int yychk[]={ + + -1000, -1, -2, 256, 262, -3, -4, -5, -6, -7, + -8, 283, -17, 273, 277, 276, 282, -2, 257, 363, + 256, -13, -11, -12, 257, 260, -9, -10, 257, 260, + 257, 262, -15, -18, -20, -25, -24, -26, 256, -27, + -28, -29, -30, -31, -32, -33, -34, -35, -36, -37, + 340, 280, 345, 346, 348, 309, 292, 307, 301, 297, + 310, 343, 299, 350, 305, 324, 351, 326, 353, 328, + 303, 338, 355, 342, -38, -39, -40, -41, -42, -43, + -44, -45, -46, 266, 257, 279, 263, 357, 366, 364, + 295, 258, 259, 260, 261, 272, 285, 287, 274, 265, + 291, 290, 271, 284, -14, 257, 360, 360, 362, -21, + 357, -19, -23, 275, 278, 286, 270, 363, 295, 338, + 313, 312, 317, 316, 347, 349, 308, 304, 302, 306, + 298, 300, 311, 294, 344, 325, 329, 333, 331, 323, + 315, 352, 356, 327, 337, 335, 321, 319, 354, 339, + 296, 341, 289, 345, 326, 336, 334, 320, 318, 353, + 324, 332, 330, 322, 314, 351, 328, 355, 346, 348, + 301, 307, 303, 305, 297, 299, 310, 293, 343, 342, + 340, 292, 364, 366, 357, 309, -36, -36, -36, -36, + -36, -36, -36, -36, -36, -36, -36, -36, -36, -36, + -36, -36, -36, -36, -36, -36, -36, -36, -36, -36, + -24, -25, -47, -25, -48, -25, -47, 272, 257, -25, + -25, -24, -24, -24, -24, -24, -24, -24, 360, -12, + -10, 258, 357, -16, -14, -20, -14, -24, -20, -26, + -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, + -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, + -27, -27, -27, -27, -27, -27, -27, -27, -27, -27, + -27, -27, -27, -29, -29, -31, -31, -31, -31, -31, + -31, -31, -31, -31, -31, -31, -31, -31, -31, -32, + -32, -33, -33, -33, -33, -34, -34, -34, -34, -34, + -36, -36, -36, -47, -24, 367, -49, -25, -47, 257, + 358, 360, 367, 363, 365, 268, 288, 281, 268, 268, + 268, 257, -22, -14, 358, 270, 363, 363, 264, 365, + -52, 362, 359, 361, 367, 360, 358, -25, -48, -24, + -24, 366, -24, -24, -24, 358, 364, -29, -24, -25, + 269, -50, -51, 267, -24, 365, 365, -24, 367, 363, + 362, 362, -51, -24, -24 }; +int yydef[]={ + + -2, -2, 0, 2, 1, 3, 4, 5, 6, 7, + 8, 0, 0, 20, 0, 0, 0, 0, 22, 34, + -2, 0, 15, 16, 18, 19, 9, 10, 12, 13, + 27, 200, 0, 38, 0, 0, 43, 44, 202, 46, + 48, 81, 84, 86, 101, 104, 109, 114, 116, 120, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 145, 146, 147, 148, 149, 150, + 151, 152, 153, 0, 155, 156, -2, -2, -2, -2, + 0, 190, 191, 192, 193, 175, -2, -2, 0, 0, + 0, 0, 0, 0, 21, 32, 0, 0, 0, 0, + 24, -2, 0, 0, 36, 37, 201, -2, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, -2, -2, -2, 0, 121, 122, 123, 124, + 125, 126, 127, 128, 129, 130, 131, 132, 133, 134, + 135, 136, 137, 138, 139, 140, 141, 142, 143, 144, + 154, 157, 0, 186, 0, 198, 0, 166, 167, 176, + 177, 43, 0, 0, 168, 170, 172, 174, 0, 17, + 11, 14, 29, 0, 25, 0, 0, 0, 41, 45, + 47, 49, 50, 51, 52, 53, 54, 55, 56, 57, + 58, 59, 60, 61, 62, 63, 64, 65, 66, 67, + 68, 69, 70, 71, 72, 73, 74, 75, 76, 77, + 78, 79, 80, 82, 85, 87, 88, 89, 90, 91, + 92, 93, 94, 95, 96, 97, 98, 99, 100, 102, + 103, 105, 106, 107, 108, 110, 111, 112, 113, 115, + 117, 118, 119, 0, 43, 162, 0, 188, 0, 165, + 158, -2, 159, -2, 160, 0, 0, 0, 0, 0, + 0, 33, 0, 30, 23, 26, 35, 39, 0, 161, + 0, 195, 196, 197, 163, -2, 164, 187, 199, 178, + 179, 0, 169, 171, 173, 28, 0, 83, 0, 189, + 0, 0, 182, 0, 0, 31, 194, 180, 181, 0, + 0, 0, 183, 184, 185 }; +typedef struct { char *t_name; int t_val; } yytoktype; +#ifndef YYDEBUG +# define YYDEBUG 0 /* don't allow debugging */ +#endif + +#if YYDEBUG + +yytoktype yytoks[] = +{ + "IDENT", 257, + "INTLIT", 258, + "REALLIT", 259, + "STRINGLIT", 260, + "CSETLIT", 261, + "EOFX", 262, + "BREAK", 263, + "BY", 264, + "CASE", 265, + "CREATE", 266, + "DEFAULT", 267, + "DO", 268, + "ELSE", 269, + "END", 270, + "EVERY", 271, + "FAIL", 272, + "GLOBAL", 273, + "IF", 274, + "INITIAL", 275, + "INVOCABLE", 276, + "LINK", 277, + "LOCAL", 278, + "NEXT", 279, + "NOT", 280, + "OF", 281, + "PROCEDURE", 282, + "RECORD", 283, + "REPEAT", 284, + "RETURN", 285, + "STATIC", 286, + "SUSPEND", 287, + "THEN", 288, + "TO", 289, + "UNTIL", 290, + "WHILE", 291, + "BANG", 292, + "MOD", 293, + "AUGMOD", 294, + "AND", 295, + "AUGAND", 296, + "STAR", 297, + "AUGSTAR", 298, + "INTER", 299, + "AUGINTER", 300, + "PLUS", 301, + "AUGPLUS", 302, + "UNION", 303, + "AUGUNION", 304, + "MINUS", 305, + "AUGMINUS", 306, + "DIFF", 307, + "AUGDIFF", 308, + "DOT", 309, + "SLASH", 310, + "AUGSLASH", 311, + "ASSIGN", 312, + "SWAP", 313, + "NMLT", 314, + "AUGNMLT", 315, + "REVASSIGN", 316, + "REVSWAP", 317, + "SLT", 318, + "AUGSLT", 319, + "SLE", 320, + "AUGSLE", 321, + "NMLE", 322, + "AUGNMLE", 323, + "NMEQ", 324, + "AUGNMEQ", 325, + "SEQ", 326, + "AUGSEQ", 327, + "EQUIV", 328, + "AUGEQUIV", 329, + "NMGT", 330, + "AUGNMGT", 331, + "NMGE", 332, + "AUGNMGE", 333, + "SGT", 334, + "AUGSGT", 335, + "SGE", 336, + "AUGSGE", 337, + "QMARK", 338, + "AUGQMARK", 339, + "AT", 340, + "AUGAT", 341, + "BACKSLASH", 342, + "CARET", 343, + "AUGCARET", 344, + "BAR", 345, + "CONCAT", 346, + "AUGCONCAT", 347, + "LCONCAT", 348, + "AUGLCONCAT", 349, + "TILDE", 350, + "NMNE", 351, + "AUGNMNE", 352, + "SNE", 353, + "AUGSNE", 354, + "NEQUIV", 355, + "AUGNEQUIV", 356, + "LPAREN", 357, + "RPAREN", 358, + "PCOLON", 359, + "COMMA", 360, + "MCOLON", 361, + "COLON", 362, + "SEMICOL", 363, + "LBRACK", 364, + "RBRACK", 365, + "LBRACE", 366, + "RBRACE", 367, + "-unknown-", -1 /* ends search */ +}; + +char * yyreds[] = +{ + "-no such reduction-", + "program : decls EOFX", + "decls : /* empty */", + "decls : decls decl", + "decl : record", + "decl : proc", + "decl : global", + "decl : link", + "decl : invocable", + "invocable : INVOCABLE invoclist", + "invoclist : invocop", + "invoclist : invoclist COMMA invocop", + "invocop : IDENT", + "invocop : STRINGLIT", + "invocop : STRINGLIT COLON INTLIT", + "link : LINK lnklist", + "lnklist : lnkfile", + "lnklist : lnklist COMMA lnkfile", + "lnkfile : IDENT", + "lnkfile : STRINGLIT", + "global : GLOBAL", + "global : GLOBAL idlist", + "record : RECORD IDENT", + "record : RECORD IDENT LPAREN fldlist RPAREN", + "fldlist : /* empty */", + "fldlist : idlist", + "proc : prochead SEMICOL locals initial procbody END", + "prochead : PROCEDURE IDENT", + "prochead : PROCEDURE IDENT LPAREN arglist RPAREN", + "arglist : /* empty */", + "arglist : idlist", + "arglist : idlist LBRACK RBRACK", + "idlist : IDENT", + "idlist : idlist COMMA IDENT", + "locals : /* empty */", + "locals : locals retention idlist SEMICOL", + "retention : LOCAL", + "retention : STATIC", + "initial : /* empty */", + "initial : INITIAL expr SEMICOL", + "procbody : /* empty */", + "procbody : nexpr SEMICOL procbody", + "nexpr : /* empty */", + "nexpr : expr", + "expr : expr1a", + "expr : expr AND expr1a", + "expr1a : expr1", + "expr1a : expr1a QMARK expr1", + "expr1 : expr2", + "expr1 : expr2 SWAP expr1", + "expr1 : expr2 ASSIGN expr1", + "expr1 : expr2 REVSWAP expr1", + "expr1 : expr2 REVASSIGN expr1", + "expr1 : expr2 AUGCONCAT expr1", + "expr1 : expr2 AUGLCONCAT expr1", + "expr1 : expr2 AUGDIFF expr1", + "expr1 : expr2 AUGUNION expr1", + "expr1 : expr2 AUGPLUS expr1", + "expr1 : expr2 AUGMINUS expr1", + "expr1 : expr2 AUGSTAR expr1", + "expr1 : expr2 AUGINTER expr1", + "expr1 : expr2 AUGSLASH expr1", + "expr1 : expr2 AUGMOD expr1", + "expr1 : expr2 AUGCARET expr1", + "expr1 : expr2 AUGNMEQ expr1", + "expr1 : expr2 AUGEQUIV expr1", + "expr1 : expr2 AUGNMGE expr1", + "expr1 : expr2 AUGNMGT expr1", + "expr1 : expr2 AUGNMLE expr1", + "expr1 : expr2 AUGNMLT expr1", + "expr1 : expr2 AUGNMNE expr1", + "expr1 : expr2 AUGNEQUIV expr1", + "expr1 : expr2 AUGSEQ expr1", + "expr1 : expr2 AUGSGE expr1", + "expr1 : expr2 AUGSGT expr1", + "expr1 : expr2 AUGSLE expr1", + "expr1 : expr2 AUGSLT expr1", + "expr1 : expr2 AUGSNE expr1", + "expr1 : expr2 AUGQMARK expr1", + "expr1 : expr2 AUGAND expr1", + "expr1 : expr2 AUGAT expr1", + "expr2 : expr3", + "expr2 : expr2 TO expr3", + "expr2 : expr2 TO expr3 BY expr3", + "expr3 : expr4", + "expr3 : expr4 BAR expr3", + "expr4 : expr5", + "expr4 : expr4 SEQ expr5", + "expr4 : expr4 SGE expr5", + "expr4 : expr4 SGT expr5", + "expr4 : expr4 SLE expr5", + "expr4 : expr4 SLT expr5", + "expr4 : expr4 SNE expr5", + "expr4 : expr4 NMEQ expr5", + "expr4 : expr4 NMGE expr5", + "expr4 : expr4 NMGT expr5", + "expr4 : expr4 NMLE expr5", + "expr4 : expr4 NMLT expr5", + "expr4 : expr4 NMNE expr5", + "expr4 : expr4 EQUIV expr5", + "expr4 : expr4 NEQUIV expr5", + "expr5 : expr6", + "expr5 : expr5 CONCAT expr6", + "expr5 : expr5 LCONCAT expr6", + "expr6 : expr7", + "expr6 : expr6 PLUS expr7", + "expr6 : expr6 DIFF expr7", + "expr6 : expr6 UNION expr7", + "expr6 : expr6 MINUS expr7", + "expr7 : expr8", + "expr7 : expr7 STAR expr8", + "expr7 : expr7 INTER expr8", + "expr7 : expr7 SLASH expr8", + "expr7 : expr7 MOD expr8", + "expr8 : expr9", + "expr8 : expr9 CARET expr8", + "expr9 : expr10", + "expr9 : expr9 BACKSLASH expr10", + "expr9 : expr9 AT expr10", + "expr9 : expr9 BANG expr10", + "expr10 : expr11", + "expr10 : AT expr10", + "expr10 : NOT expr10", + "expr10 : BAR expr10", + "expr10 : CONCAT expr10", + "expr10 : LCONCAT expr10", + "expr10 : DOT expr10", + "expr10 : BANG expr10", + "expr10 : DIFF expr10", + "expr10 : PLUS expr10", + "expr10 : STAR expr10", + "expr10 : SLASH expr10", + "expr10 : CARET expr10", + "expr10 : INTER expr10", + "expr10 : TILDE expr10", + "expr10 : MINUS expr10", + "expr10 : NMEQ expr10", + "expr10 : NMNE expr10", + "expr10 : SEQ expr10", + "expr10 : SNE expr10", + "expr10 : EQUIV expr10", + "expr10 : UNION expr10", + "expr10 : QMARK expr10", + "expr10 : NEQUIV expr10", + "expr10 : BACKSLASH expr10", + "expr11 : literal", + "expr11 : section", + "expr11 : return", + "expr11 : if", + "expr11 : case", + "expr11 : while", + "expr11 : until", + "expr11 : every", + "expr11 : repeat", + "expr11 : CREATE expr", + "expr11 : IDENT", + "expr11 : NEXT", + "expr11 : BREAK nexpr", + "expr11 : LPAREN exprlist RPAREN", + "expr11 : LBRACE compound RBRACE", + "expr11 : LBRACK exprlist RBRACK", + "expr11 : expr11 LBRACK exprlist RBRACK", + "expr11 : expr11 LBRACE RBRACE", + "expr11 : expr11 LBRACE pdcolist RBRACE", + "expr11 : expr11 LPAREN exprlist RPAREN", + "expr11 : expr11 DOT IDENT", + "expr11 : AND FAIL", + "expr11 : AND IDENT", + "while : WHILE expr", + "while : WHILE expr DO expr", + "until : UNTIL expr", + "until : UNTIL expr DO expr", + "every : EVERY expr", + "every : EVERY expr DO expr", + "repeat : REPEAT expr", + "return : FAIL", + "return : RETURN nexpr", + "return : SUSPEND nexpr", + "return : SUSPEND expr DO expr", + "if : IF expr THEN expr", + "if : IF expr THEN expr ELSE expr", + "case : CASE expr OF LBRACE caselist RBRACE", + "caselist : cclause", + "caselist : caselist SEMICOL cclause", + "cclause : DEFAULT COLON expr", + "cclause : expr COLON expr", + "exprlist : nexpr", + "exprlist : exprlist COMMA nexpr", + "pdcolist : nexpr", + "pdcolist : pdcolist COMMA nexpr", + "literal : INTLIT", + "literal : REALLIT", + "literal : STRINGLIT", + "literal : CSETLIT", + "section : expr11 LBRACK expr sectop expr RBRACK", + "sectop : COLON", + "sectop : PCOLON", + "sectop : MCOLON", + "compound : nexpr", + "compound : nexpr SEMICOL compound", + "program : error decls EOFX", + "proc : prochead error procbody END", + "expr : error", +}; +#endif +#line 1 "/usr/lib/yaccpar" +/* @(#)yaccpar 1.10 89/04/04 SMI; from S5R3 1.10 */ + +/* +** Skeleton parser driver for yacc output +*/ + +/* +** yacc user known macros and defines +*/ +#define YYERROR goto yyerrlab +#define YYACCEPT { free(yys); free(yyv); return(0); } +#define YYABORT { free(yys); free(yyv); return(1); } +#define YYBACKUP( newtoken, newvalue )\ +{\ + if ( yychar >= 0 || ( yyr2[ yytmp ] >> 1 ) != 1 )\ + {\ + tsyserr("parser: syntax error - cannot backup" );\ + goto yyerrlab;\ + }\ + yychar = newtoken;\ + yystate = *yyps;\ + yylval = newvalue;\ + goto yynewstate;\ +} +#define YYRECOVERING() (!!yyerrflag) +#ifndef YYDEBUG +# define YYDEBUG 1 /* make debugging available */ +#endif + +/* +** user known globals +*/ +int yydebug; /* set to 1 to get debugging */ + +/* +** driver internal defines +*/ +#define YYFLAG (-1000) + +/* +** static variables used by the parser +*/ +static YYSTYPE *yyv; /* value stack */ +static int *yys; /* state stack */ + +static YYSTYPE *yypv; /* top of value stack */ +static int *yyps; /* top of state stack */ + +static int yystate; /* current state */ +static int yytmp; /* extra var (lasts between blocks) */ + +int yynerrs; /* number of errors */ + +int yyerrflag; /* error recovery flag */ +int yychar; /* current input token number */ + + +/* +** yyparse - return 0 if worked, 1 if syntax error not recovered from +*/ +int +yyparse() +{ + register YYSTYPE *yypvt; /* top of value stack for $vars */ + unsigned yymaxdepth = YYMAXDEPTH; + + /* + ** Initialize externals - yyparse may be called more than once + */ + yyv = (YYSTYPE*)malloc(yymaxdepth*sizeof(YYSTYPE)); + yys = (int*)malloc(yymaxdepth*sizeof(int)); + if (!yyv || !yys) + { + tsyserr("parser: out of memory" ); + return(1); + } + yypv = &yyv[-1]; + yyps = &yys[-1]; + yystate = 0; + yytmp = 0; + yynerrs = 0; + yyerrflag = 0; + yychar = -1; + + goto yystack; + { + register YYSTYPE *yy_pv; /* top of value stack */ + register int *yy_ps; /* top of state stack */ + register int yy_state; /* current state */ + register int yy_n; /* internal state number info */ + + /* + ** get globals into registers. + ** branch to here only if YYBACKUP was called. + */ + yynewstate: + yy_pv = yypv; + yy_ps = yyps; + yy_state = yystate; + goto yy_newstate; + + /* + ** get globals into registers. + ** either we just started, or we just finished a reduction + */ + yystack: + yy_pv = yypv; + yy_ps = yyps; + yy_state = yystate; + + /* + ** top of for (;;) loop while no reductions done + */ + yy_stack: + /* + ** put a state and value onto the stacks + */ +#if YYDEBUG + /* + ** if debugging, look up token value in list of value vs. + ** name pairs. 0 and negative (-1) are special values. + ** Note: linear search is used since time is not a real + ** consideration while debugging. + */ + if ( yydebug ) + { + register int yy_i; + + (void)printf( "State %d, token ", yy_state ); + if ( yychar == 0 ) + (void)printf( "end-of-file\n" ); + else if ( yychar < 0 ) + (void)printf( "-none-\n" ); + else + { + for ( yy_i = 0; yytoks[yy_i].t_val >= 0; + yy_i++ ) + { + if ( yytoks[yy_i].t_val == yychar ) + break; + } + (void)printf( "%s\n", yytoks[yy_i].t_name ); + } + } +#endif + if ( ++yy_ps >= &yys[ yymaxdepth ] ) /* room on stack? */ + { + /* + ** reallocate and recover. Note that pointers + ** have to be reset, or bad things will happen + */ + int yyps_index = (yy_ps - yys); + int yypv_index = (yy_pv - yyv); + int yypvt_index = (yypvt - yyv); + yymaxdepth += YYMAXDEPTH; + yyv = (YYSTYPE*)realloc((char*)yyv, + yymaxdepth * sizeof(YYSTYPE)); + yys = (int*)realloc((char*)yys, + yymaxdepth * sizeof(int)); + if (!yyv || !yys) + { + tsyserr("parse stack overflow" ); + return(1); + } + yy_ps = yys + yyps_index; + yy_pv = yyv + yypv_index; + yypvt = yyv + yypvt_index; + } + *yy_ps = yy_state; + *++yy_pv = yyval; + + /* + ** we have a new state - find out what to do + */ + yy_newstate: + if ( ( yy_n = yypact[ yy_state ] ) <= YYFLAG ) + goto yydefault; /* simple state */ +#if YYDEBUG + /* + ** if debugging, need to mark whether new token grabbed + */ + yytmp = yychar < 0; +#endif + if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) ) + yychar = 0; /* reached EOF */ +#if YYDEBUG + if ( yydebug && yytmp ) + { + register int yy_i; + + (void)printf( "Received token " ); + if ( yychar == 0 ) + (void)printf( "end-of-file\n" ); + else if ( yychar < 0 ) + (void)printf( "-none-\n" ); + else + { + for ( yy_i = 0; yytoks[yy_i].t_val >= 0; + yy_i++ ) + { + if ( yytoks[yy_i].t_val == yychar ) + break; + } + (void)printf( "%s\n", yytoks[yy_i].t_name ); + } + } +#endif + if ( ( ( yy_n += yychar ) < 0 ) || ( yy_n >= YYLAST ) ) + goto yydefault; + if ( yychk[ yy_n = yyact[ yy_n ] ] == yychar ) /*valid shift*/ + { + yychar = -1; + yyval = yylval; + yy_state = yy_n; + if ( yyerrflag > 0 ) + yyerrflag--; + goto yy_stack; + } + + yydefault: + if ( ( yy_n = yydef[ yy_state ] ) == -2 ) + { +#if YYDEBUG + yytmp = yychar < 0; +#endif + if ( ( yychar < 0 ) && ( ( yychar = yylex() ) < 0 ) ) + yychar = 0; /* reached EOF */ +#if YYDEBUG + if ( yydebug && yytmp ) + { + register int yy_i; + + (void)printf( "Received token " ); + if ( yychar == 0 ) + (void)printf( "end-of-file\n" ); + else if ( yychar < 0 ) + (void)printf( "-none-\n" ); + else + { + for ( yy_i = 0; + yytoks[yy_i].t_val >= 0; + yy_i++ ) + { + if ( yytoks[yy_i].t_val + == yychar ) + { + break; + } + } + (void)printf( "%s\n", yytoks[yy_i].t_name ); + } + } +#endif + /* + ** look through exception table + */ + { + register int *yyxi = yyexca; + + while ( ( *yyxi != -1 ) || + ( yyxi[1] != yy_state ) ) + { + yyxi += 2; + } + while ( ( *(yyxi += 2) >= 0 ) && + ( *yyxi != yychar ) ) + ; + if ( ( yy_n = yyxi[1] ) < 0 ) + YYACCEPT; + } + } + + /* + ** check for syntax error + */ + if ( yy_n == 0 ) /* have an error */ + { + /* no worry about speed here! */ + switch ( yyerrflag ) + { + case 0: /* new error */ + yyerror(yychar, yylval, yy_state ); + goto skip_init; + yyerrlab: + /* + ** get globals into registers. + ** we have a user generated syntax type error + */ + yy_pv = yypv; + yy_ps = yyps; + yy_state = yystate; + yynerrs++; + skip_init: + case 1: + case 2: /* incompletely recovered error */ + /* try again... */ + yyerrflag = 3; + /* + ** find state where "error" is a legal + ** shift action + */ + while ( yy_ps >= yys ) + { + yy_n = yypact[ *yy_ps ] + YYERRCODE; + if ( yy_n >= 0 && yy_n < YYLAST && + yychk[yyact[yy_n]] == YYERRCODE) { + /* + ** simulate shift of "error" + */ + yy_state = yyact[ yy_n ]; + goto yy_stack; + } + /* + ** current state has no shift on + ** "error", pop stack + */ +#if YYDEBUG +# define _POP_ "Error recovery pops state %d, uncovers state %d\n" + if ( yydebug ) + (void)printf( _POP_, *yy_ps, + yy_ps[-1] ); +# undef _POP_ +#endif + yy_ps--; + yy_pv--; + } + /* + ** there is no state on stack with "error" as + ** a valid shift. give up. + */ + YYABORT; + case 3: /* no shift yet; eat a token */ +#if YYDEBUG + /* + ** if debugging, look up token in list of + ** pairs. 0 and negative shouldn't occur, + ** but since timing doesn't matter when + ** debugging, it doesn't hurt to leave the + ** tests here. + */ + if ( yydebug ) + { + register int yy_i; + + (void)printf( "Error recovery discards " ); + if ( yychar == 0 ) + (void)printf( "token end-of-file\n" ); + else if ( yychar < 0 ) + (void)printf( "token -none-\n" ); + else + { + for ( yy_i = 0; + yytoks[yy_i].t_val >= 0; + yy_i++ ) + { + if ( yytoks[yy_i].t_val + == yychar ) + { + break; + } + } + (void)printf( "token %s\n", + yytoks[yy_i].t_name ); + } + } +#endif + if ( yychar == 0 ) /* reached EOF. quit */ + YYABORT; + yychar = -1; + goto yy_newstate; + } + }/* end if ( yy_n == 0 ) */ + /* + ** reduction by production yy_n + ** put stack tops, etc. so things right after switch + */ +#if YYDEBUG + /* + ** if debugging, print the string that is the user's + ** specification of the reduction which is just about + ** to be done. + */ + if ( yydebug ) + (void)printf( "Reduce by (%d) \"%s\"\n", + yy_n, yyreds[ yy_n ] ); +#endif + yytmp = yy_n; /* value to switch over */ + yypvt = yy_pv; /* $vars top of value stack */ + /* + ** Look in goto table for next state + ** Sorry about using yy_state here as temporary + ** register variable, but why not, if it works... + ** If yyr2[ yy_n ] doesn't have the low order bit + ** set, then there is no action to be done for + ** this reduction. So, no saving & unsaving of + ** registers done. The only difference between the + ** code just after the if and the body of the if is + ** the goto yy_stack in the body. This way the test + ** can be made before the choice of what to do is needed. + */ + { + /* length of production doubled with extra bit */ + register int yy_len = yyr2[ yy_n ]; + + if ( !( yy_len & 01 ) ) + { + yy_len >>= 1; + yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */ + yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] + + *( yy_ps -= yy_len ) + 1; + if ( yy_state >= YYLAST || + yychk[ yy_state = + yyact[ yy_state ] ] != -yy_n ) + { + yy_state = yyact[ yypgo[ yy_n ] ]; + } + goto yy_stack; + } + yy_len >>= 1; + yyval = ( yy_pv -= yy_len )[1]; /* $$ = $1 */ + yy_state = yypgo[ yy_n = yyr1[ yy_n ] ] + + *( yy_ps -= yy_len ) + 1; + if ( yy_state >= YYLAST || + yychk[ yy_state = yyact[ yy_state ] ] != -yy_n ) + { + yy_state = yyact[ yypgo[ yy_n ] ]; + } + } + /* save until reenter driver code */ + yystate = yy_state; + yyps = yy_ps; + yypv = yy_pv; + } + /* + ** code supplied by user is placed in this switch + */ + switch( yytmp ) + { + +case 1: +# line 179 "tgram.g" +{gout(globfile);} break; +case 4: +# line 184 "tgram.g" +{if (!nocode) rout(globfile, Str0(yypvt[-0])); nocode = 0; loc_init();} break; +case 5: +# line 185 "tgram.g" +{if (!nocode) codegen(yypvt[-0]); nocode = 0; loc_init();} break; +case 6: +# line 186 "tgram.g" +{;} break; +case 7: +# line 187 "tgram.g" +{;} break; +case 8: +# line 188 "tgram.g" +{;} break; +case 9: +# line 190 "tgram.g" +{;} break; +case 11: +# line 193 "tgram.g" +{;} break; +case 12: +# line 195 "tgram.g" +{addinvk(Str0(yypvt[-0]),1);} break; +case 13: +# line 196 "tgram.g" +{addinvk(Str0(yypvt[-0]),2);} break; +case 14: +# line 197 "tgram.g" +{addinvk(Str0(yypvt[-2]),3);} break; +case 15: +# line 199 "tgram.g" +{;} break; +case 17: +# line 202 "tgram.g" +{;} break; +case 18: +# line 204 "tgram.g" +{addlfile(Str0(yypvt[-0]));} break; +case 19: +# line 205 "tgram.g" +{addlfile(Str0(yypvt[-0]));} break; +case 20: +# line 207 "tgram.g" +{idflag = F_Global;} break; +case 21: +# line 207 "tgram.g" +{;} break; +case 22: +# line 209 "tgram.g" +{idflag = F_Argument;} break; +case 23: +# line 209 "tgram.g" +{ + install(Str0(yypvt[-4]),F_Record|F_Global,id_cnt); yyval = yypvt[-4]; + } break; +case 24: +# line 213 "tgram.g" +{id_cnt = 0;} break; +case 25: +# line 214 "tgram.g" +{;} break; +case 26: +# line 216 "tgram.g" +{ + yyval = tree6(N_Proc,yypvt[-5],yypvt[-5],yypvt[-2],yypvt[-1],yypvt[-0]); + } break; +case 27: +# line 220 "tgram.g" +{idflag = F_Argument;} break; +case 28: +# line 220 "tgram.g" +{ + yyval = yypvt[-4]; install(Str0(yypvt[-4]),F_Proc|F_Global,id_cnt); + } break; +case 29: +# line 224 "tgram.g" +{id_cnt = 0;} break; +case 30: +# line 225 "tgram.g" +{;} break; +case 31: +# line 226 "tgram.g" +{id_cnt = -id_cnt;} break; +case 32: +# line 229 "tgram.g" +{ + install(Str0(yypvt[-0]),idflag,0); id_cnt = 1; + } break; +case 33: +# line 232 "tgram.g" +{ + install(Str0(yypvt[-0]),idflag,0); ++id_cnt; + } break; +case 34: +# line 236 "tgram.g" +{;} break; +case 35: +# line 237 "tgram.g" +{;} break; +case 36: +# line 239 "tgram.g" +{idflag = F_Dynamic;} break; +case 37: +# line 240 "tgram.g" +{idflag = F_Static;} break; +case 38: +# line 242 "tgram.g" +{yyval = tree1(N_Empty);} break; +case 39: +# line 243 "tgram.g" +{yyval = yypvt[-1];} break; +case 40: +# line 245 "tgram.g" +{yyval = tree1(N_Empty);} break; +case 41: +# line 246 "tgram.g" +{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 42: +# line 248 "tgram.g" +{yyval = tree1(N_Empty);} break; +case 45: +# line 252 "tgram.g" +{yyval = tree5(N_Conj,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 47: +# line 255 "tgram.g" +{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 49: +# line 258 "tgram.g" +case 50: +# line 259 "tgram.g" +case 51: +# line 260 "tgram.g" +case 52: +# line 261 "tgram.g" +{yyval = tree5(N_Binop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 53: +# line 262 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 54: +# line 263 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 55: +# line 264 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 56: +# line 265 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 57: +# line 266 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 58: +# line 267 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 59: +# line 268 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 60: +# line 269 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 61: +# line 270 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 62: +# line 271 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 63: +# line 272 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 64: +# line 273 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 65: +# line 274 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 66: +# line 275 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 67: +# line 276 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 68: +# line 277 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 69: +# line 278 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 70: +# line 279 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 71: +# line 280 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 72: +# line 281 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 73: +# line 282 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 74: +# line 283 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 75: +# line 284 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 76: +# line 285 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 77: +# line 286 "tgram.g" +{yyval = tree5(N_Augop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 78: +# line 287 "tgram.g" +{yyval = tree5(N_Scan,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 79: +# line 288 "tgram.g" +{yyval = tree5(N_Conj,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 80: +# line 289 "tgram.g" +{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-0],yypvt[-2]);} break; +case 82: +# line 292 "tgram.g" +{yyval = tree4(N_To,yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 83: +# line 293 "tgram.g" +{yyval = tree5(N_ToBy,yypvt[-3],yypvt[-4],yypvt[-2],yypvt[-0]);} break; +case 85: +# line 296 "tgram.g" +{yyval = tree4(N_Alt,yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 87: +# line 299 "tgram.g" +case 88: +# line 300 "tgram.g" +case 89: +# line 301 "tgram.g" +case 90: +# line 302 "tgram.g" +case 91: +# line 303 "tgram.g" +case 92: +# line 304 "tgram.g" +case 93: +# line 305 "tgram.g" +case 94: +# line 306 "tgram.g" +case 95: +# line 307 "tgram.g" +case 96: +# line 308 "tgram.g" +case 97: +# line 309 "tgram.g" +case 98: +# line 310 "tgram.g" +case 99: +# line 311 "tgram.g" +case 100: +# line 312 "tgram.g" +case 102: +# line 315 "tgram.g" +case 103: +# line 316 "tgram.g" +case 105: +# line 319 "tgram.g" +case 106: +# line 320 "tgram.g" +case 107: +# line 321 "tgram.g" +case 108: +# line 322 "tgram.g" +case 110: +# line 325 "tgram.g" +case 111: +# line 326 "tgram.g" +case 112: +# line 327 "tgram.g" +case 113: +# line 328 "tgram.g" +case 115: +# line 331 "tgram.g" +{yyval = tree5(N_Binop,yypvt[-1],yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 117: +# line 334 "tgram.g" +{yyval = tree4(N_Limit,yypvt[-2],yypvt[-2],yypvt[-0]);} break; +case 118: +# line 335 "tgram.g" +{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-0],yypvt[-2]);} break; +case 119: +# line 336 "tgram.g" +{yyval = tree4(N_Apply,yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 121: +# line 339 "tgram.g" +{yyval = tree5(N_Activat,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty));} break; +case 122: +# line 340 "tgram.g" +{yyval = tree3(N_Not,yypvt[-0],yypvt[-0]);} break; +case 123: +# line 341 "tgram.g" +{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]);} break; +case 124: +# line 342 "tgram.g" +{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]);} break; +case 125: +# line 343 "tgram.g" +{yyval = tree3(N_Bar,yypvt[-0],yypvt[-0]);} break; +case 126: +# line 344 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 127: +# line 345 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 128: +# line 346 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 129: +# line 347 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 130: +# line 348 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 131: +# line 349 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 132: +# line 350 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 133: +# line 351 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 134: +# line 352 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 135: +# line 353 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 136: +# line 354 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 137: +# line 355 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 138: +# line 356 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 139: +# line 357 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 140: +# line 358 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 141: +# line 359 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 142: +# line 360 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 143: +# line 361 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 144: +# line 362 "tgram.g" +{yyval = tree4(N_Unop,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 154: +# line 373 "tgram.g" +{yyval = tree3(N_Create,yypvt[-1],yypvt[-0]);} break; +case 155: +# line 374 "tgram.g" +{Val0(yypvt[-0]) = putloc(Str0(yypvt[-0]),0);} break; +case 156: +# line 375 "tgram.g" +{yyval = tree2(N_Next,yypvt[-0]);} break; +case 157: +# line 376 "tgram.g" +{yyval = tree3(N_Break,yypvt[-1],yypvt[-0]);} break; +case 158: +# line 377 "tgram.g" +{if ((yypvt[-1])->n_type == N_Elist) yyval = tree4(N_Invok,yypvt[-2],tree1(N_Empty),yypvt[-1]); else yyval = yypvt[-1];} break; +case 159: +# line 378 "tgram.g" +{yyval = yypvt[-1];} break; +case 160: +# line 379 "tgram.g" +{yyval = tree3(N_List,yypvt[-2],yypvt[-1]);} break; +case 161: +# line 380 "tgram.g" +{yyval = buildarray(yypvt[-3],yypvt[-2],yypvt[-1],yypvt[-0]);} break; +case 162: +# line 381 "tgram.g" +{yyval = tree4(N_Invok,yypvt[-1],yypvt[-2], tree3(N_List,yypvt[-1],tree1(N_Empty)));} break; +case 163: +# line 382 "tgram.g" +{yyval = tree4(N_Invok,yypvt[-2],yypvt[-3],tree3(N_List,yypvt[-2],yypvt[-1]));} break; +case 164: +# line 383 "tgram.g" +{yyval = tree4(N_Invok,yypvt[-2],yypvt[-3],yypvt[-1]);} break; +case 165: +# line 384 "tgram.g" +{yyval = tree4(N_Field,yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 166: +# line 385 "tgram.g" +{yyval = c_str_leaf(N_Key,yypvt[-1],"fail");} break; +case 167: +# line 386 "tgram.g" +{if (klookup(Str0(yypvt[-0])) == 0) tfatal("invalid keyword",Str0(yypvt[-0])); yyval = c_str_leaf(N_Key,yypvt[-1],Str0(yypvt[-0]));} break; +case 168: +# line 388 "tgram.g" +{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty));} break; +case 169: +# line 389 "tgram.g" +{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]);} break; +case 170: +# line 391 "tgram.g" +{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty));} break; +case 171: +# line 392 "tgram.g" +{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]);} break; +case 172: +# line 394 "tgram.g" +{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty));} break; +case 173: +# line 395 "tgram.g" +{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]);} break; +case 174: +# line 397 "tgram.g" +{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty));} break; +case 175: +# line 399 "tgram.g" +{yyval = tree4(N_Ret,yypvt[-0],yypvt[-0],tree1(N_Empty));} break; +case 176: +# line 400 "tgram.g" +{yyval = tree4(N_Ret,yypvt[-1],yypvt[-1],yypvt[-0]);} break; +case 177: +# line 401 "tgram.g" +{yyval = tree5(N_Loop,yypvt[-1],yypvt[-1],yypvt[-0],tree1(N_Empty));} break; +case 178: +# line 402 "tgram.g" +{yyval = tree5(N_Loop,yypvt[-3],yypvt[-3],yypvt[-2],yypvt[-0]);} break; +case 179: +# line 404 "tgram.g" +{yyval = tree5(N_If,yypvt[-3],yypvt[-2],yypvt[-0],tree1(N_Empty));} break; +case 180: +# line 405 "tgram.g" +{yyval = tree5(N_If,yypvt[-5],yypvt[-4],yypvt[-2],yypvt[-0]);} break; +case 181: +# line 407 "tgram.g" +{yyval = tree4(N_Case,yypvt[-5],yypvt[-4],yypvt[-1]);} break; +case 183: +# line 410 "tgram.g" +{yyval = tree4(N_Clist,yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 184: +# line 412 "tgram.g" +{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 185: +# line 413 "tgram.g" +{yyval = tree4(N_Ccls,yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 186: +# line 415 "tgram.g" +{;} break; +case 187: +# line 416 "tgram.g" +{yyval = tree4(N_Elist,yypvt[-1],yypvt[-2],yypvt[-0]);} break; +case 188: +# line 418 "tgram.g" +{ + yyval = tree3(N_Create,yypvt[-0],yypvt[-0]); + } break; +case 189: +# line 421 "tgram.g" +{ + yyval = tree4(N_Elist,yypvt[-1],yypvt[-2],tree3(N_Create,yypvt[-1],yypvt[-0])); + } break; +case 190: +# line 425 "tgram.g" +{Val0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_IntLit,0);} break; +case 191: +# line 426 "tgram.g" +{Val0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_RealLit,0);} break; +case 192: +# line 427 "tgram.g" +{Val0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_StrLit,(int)Val1(yypvt[-0]));} break; +case 193: +# line 428 "tgram.g" +{Val0(yypvt[-0]) = putlit(Str0(yypvt[-0]),F_CsetLit,(int)Val1(yypvt[-0]));} break; +case 194: +# line 430 "tgram.g" +{yyval = tree6(N_Sect,yypvt[-2],yypvt[-2],yypvt[-5],yypvt[-3],yypvt[-1]);} break; +case 195: +# line 432 "tgram.g" +{yyval = yypvt[-0];} break; +case 196: +# line 433 "tgram.g" +{yyval = yypvt[-0];} break; +case 197: +# line 434 "tgram.g" +{yyval = yypvt[-0];} break; +case 199: +# line 437 "tgram.g" +{yyval = tree4(N_Slist,yypvt[-1],yypvt[-2],yypvt[-0]);} break; + } + goto yystack; /* reset registers in driver code */ +} diff --git a/src/icont/tproto.h b/src/icont/tproto.h new file mode 100644 index 0000000..aaea6c4 --- /dev/null +++ b/src/icont/tproto.h @@ -0,0 +1,106 @@ +/* + * Prototypes for functions in icont. + */ + +void addinvk (char *name, int n); +void addlfile (char *name); +pointer alloc (unsigned int n); +void alsolink (char *name); +int blocate (word s); +struct node *c_str_leaf (int type,struct node *loc_model, char *c); +void codegen (struct node *t); +void constout (FILE *fd); +void dummyda (void); +struct fentry *flocate (word id); +struct fileparts *fparse (char *s); +void gencode (void); +void gentables (void); +int getdec (void); +int getopr (int ac, int *cc); +word getid (void); +long getint (int i, word *wp); +int getlab (void); +struct lfile *getlfile (struct lfile * *lptr); +int getoct (void); +int getopc (char * *id); +double getreal (void); +word getrest (void); +word getstr (void); +word getstrlit (int l); +struct gentry *glocate (word id); +void gout (FILE *fd); +struct node *i_str_leaf (int type,struct node *loc_model,char *c,int d); +int ilink (char * *ifiles,char *outname); +void initglob (void); +void install (char *name,int flag,int argcnt); +word instid (char *s); +struct node *int_leaf (int type,struct node *loc_model,int c); +int klookup (char *id); +int lexeql (int l,char *s1,char *s2); +void lfatal (char *s1,char *s2); +void linit (void); +void lmfree (void); +void loc_init (void); +void locinit (void); +void lout (FILE *fd); +void lwarn (char *s1,char *s2,char *s3); +char *makename (char *dest,char *d,char *name,char *e); +void newline (void); +int nextchar (void); +void nfatal (struct node *n,char *s1,char *s2); +void putconst (int n,int flags,int len,word pc, union xval *valp); +void putfield (word fname,struct gentry *gp,int fnum); +struct gentry *putglobal (word id,int flags,int nargs, int procid); +char *putid (int len); +word putident (int len, int install); +int putlit (char *id,int idtype,int len); +int putloc (char *id,int id_type); +void putlocal (int n,word id,int flags,int imperror, + word procname); +void quit (char *msg); +void quitf (char *msg,char *arg); +void readglob (void); +void report (char *s); +unsigned int round2 (unsigned int n); +void rout (FILE *fd,char *name); +char *salloc (char *s); +void scanrefs (void); +void sizearg (char *arg,char * *argv); +int smatch (char *s,char *t); +pointer tcalloc (unsigned int m,unsigned int n); +void tfatal (char *s1,char *s2); +void tmalloc (void); +void tmfree (void); +void tminit (void); +int trans (char * *ifiles, char *tgtdir); +pointer trealloc (pointer table, pointer tblfree, + unsigned int *size, int unit_size, + int min_units, char *tbl_name); +struct node *tree1 (int type); +struct node *tree2 (int type,struct node *loc_model); +struct node *tree3 (int type,struct node *loc_model,struct node *c); +struct node *tree4 (int type,struct node *loc_model,struct node *c,struct node *d); +struct node *tree5 (int type,struct node *loc_model, + struct node *c,struct node *d, + struct node *e); +struct node *tree6 (int type,struct node *loc_model, + struct node *c, struct node *d, + struct node *e,struct node *f); +struct node *buildarray (struct node *a,struct node *lb, + struct node *e, struct node *rb); +void treeinit (void); +void tsyserr (char *s); +void writecheck (int rc); +void yyerror (int tok,struct node *lval,int state); +int yylex (void); +int yyparse (void); + +#ifdef DeBugTrans + void cdump (void); + void gdump (void); + void ldump (void); +#endif /* DeBugTrans */ + +#ifdef DeBugLinker + void idump (char *c); +#endif /* DeBugLinker */ diff --git a/src/icont/trans.c b/src/icont/trans.c new file mode 100644 index 0000000..c27b1f6 --- /dev/null +++ b/src/icont/trans.c @@ -0,0 +1,125 @@ +/* + * trans.c - main control of the translation process. + */ + +#include "../h/gsupport.h" +#include "tproto.h" +#include "../h/version.h" +#include "tglobals.h" +#include "tsym.h" +#include "tree.h" +#include "ttoken.h" + +/* + * Prototypes. + */ + +static void trans1 (char *filename, char *tgtdir); + +int tfatals; /* number of fatal errors in file */ +int afatals; /* total number of fatal errors */ +int nocode; /* non-zero to suppress code generation */ +int in_line; /* current input line number */ +int incol; /* current input column number */ +int peekc; /* one-character look ahead */ + +/* + * translate a number of files, returning an error count + */ +int trans(ifiles, tgtdir) +char **ifiles; +char *tgtdir; + { + afatals = 0; + + tmalloc(); /* allocate memory for translation */ + while (*ifiles) { + trans1(*ifiles++, tgtdir); /* translate each file in turn */ + afatals += tfatals; + } + tmfree(); /* free memory used for translation */ + + /* + * Report information about errors and warnings and be correct about it. + */ + if (afatals == 1) + report("1 error\n"); + else if (afatals > 1) { + char tmp[12]; + sprintf(tmp, "%d errors\n", afatals); + report(tmp); + } + else + report("No errors\n"); + + return afatals; + } + +/* + * translate one file. + */ +static void trans1(filename, tgtdir) +char *filename, *tgtdir; +{ + char oname1[MaxPath]; /* buffer for constructing file name */ + char oname2[MaxPath]; /* buffer for constructing file name */ + + tfatals = 0; /* reset error counts */ + nocode = 0; /* allow code generation */ + in_line = 1; /* start with line 1, column 0 */ + incol = 0; + peekc = 0; /* clear character lookahead */ + + if (!ppinit(filename,lpath,m4pre)) + quitf("cannot open %s",filename); + + if (strcmp(filename,"-") == 0) + filename = "stdin"; + + report(filename); + + if (pponly) { + ppecho(); + return; + } + + /* + * Form names for the .u1 and .u2 files and open them. + * Write the ucode version number to the .u2 file. + */ + makename(oname1, tgtdir, filename, U1Suffix); + codefile = fopen(oname1, "w"); + if (codefile == NULL) + quitf("cannot create %s", oname1); + makename(oname2, tgtdir, filename, U2Suffix); + globfile = fopen(oname2, "w"); + if (globfile == NULL) + quitf("cannot create %s", oname2); + writecheck(fprintf(globfile,"version\t%s\n",UVersion)); + + tok_loc.n_file = filename; + in_line = 1; + + tminit(); /* Initialize data structures */ + yyparse(); /* Parse the input */ + + /* + * Close the output files. + */ + if (fclose(codefile) != 0 || fclose(globfile) != 0) + quit("cannot close ucode file"); + if (tfatals) { + remove(oname1); + remove(oname2); + } + } + +/* + * writecheck - check the return code from a stdio output operation + */ +void writecheck(rc) +int rc; + { + if (rc < 0) + quit("cannot write to ucode file"); +} diff --git a/src/icont/trash.icn b/src/icont/trash.icn new file mode 100644 index 0000000..a94594b --- /dev/null +++ b/src/icont/trash.icn @@ -0,0 +1,35 @@ +# +# This is an ad-hoc program for removing duplicate code in the main switch +# statement for binary operators (the optimizer should fold these, if +# the compiler can get that far). +# +# This program relies on the form of parse.c as presently produced; it is +# fragile and may need modification for other versions of parse.c. Look +# at your parse.c first to see if the template is correct. +# +# The same thing could be done for N_Unop, but if this works, that will not +# be necesssary. + +procedure main() + template := "{yyval = tree5(N_Binop" + while line := read () do { + if not(match(template,line)) then + write(line) # copy until "offending member" is found + else { + lastline := line # save it for last case in group + buffer := [] # push-back buffer + repeat { + put(buffer,read()) # "case ..." + put(buffer,read()) # "# line ... + line := read() + if not match(template,line) then { + write(lastline) # if not a duplicate, insert the one instance + while write(get(buffer)) # write out lines pushed back + write(line) # write the new line + break # break back to the main loop (may be more) + } + else while write(get(buffer)) # else write out lines pushed back + } + } + } +end diff --git a/src/icont/tree.c b/src/icont/tree.c new file mode 100644 index 0000000..535c62a --- /dev/null +++ b/src/icont/tree.c @@ -0,0 +1,175 @@ +/* + * tree.c -- functions for constructing parse trees + */ + +#include "../h/gsupport.h" +#include "tproto.h" +#include "tree.h" + +/* + * tree[1-6] construct parse tree nodes with specified values. + * Parameters a and b are line and column information, + * while parameters c through f are values to be assigned to n_field[0-3]. + * Note that this could be done with a single routine; a separate routine + * for each node size is used for speed and simplicity. + */ + +nodeptr tree1(type) +int type; + { + register nodeptr t; + + t = NewNode(0); + t->n_type = type; + return t; + } + +nodeptr tree2(type, loc_model) +int type; +nodeptr loc_model; + { + register nodeptr t; + + t = NewNode(0); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + return t; + } + +nodeptr tree3(type, loc_model, c) +int type; +nodeptr loc_model; +nodeptr c; + { + register nodeptr t; + + t = NewNode(1); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->n_field[0].n_ptr = c; + return t; + } + +nodeptr tree4(type, loc_model, c, d) +int type; +nodeptr loc_model; +nodeptr c, d; + { + register nodeptr t; + + t = NewNode(2); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->n_field[0].n_ptr = c; + t->n_field[1].n_ptr = d; + return t; + } + +nodeptr tree5(type, loc_model, c, d, e) +int type; +nodeptr loc_model; +nodeptr c, d, e; + { + register nodeptr t; + + t = NewNode(3); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->n_field[0].n_ptr = c; + t->n_field[1].n_ptr = d; + t->n_field[2].n_ptr = e; + return t; + } + +nodeptr tree6(type, loc_model, c, d, e, f) +int type; +nodeptr loc_model; +nodeptr c, d, e, f; + { + register nodeptr t; + + t = NewNode(4); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->n_field[0].n_ptr = c; + t->n_field[1].n_ptr = d; + t->n_field[2].n_ptr = e; + t->n_field[3].n_ptr = f; + return t; + } + +nodeptr buildarray(a,lb,e,rb) +nodeptr a, lb, e, rb; + { + register nodeptr t, t2; + if (e->n_type == N_Elist) { + t2 = int_leaf(lb->n_type, lb, (int)lb->n_field[0].n_val); + t = tree5(N_Binop, t2, t2, buildarray(a,lb,e->n_field[0].n_ptr,rb), + e->n_field[1].n_ptr); + free(e); + } + else + t = tree5(N_Binop, lb, lb, a, e); + return t; + } + +nodeptr int_leaf(type, loc_model, c) +int type; +nodeptr loc_model; +int c; + { + register nodeptr t; + + t = NewNode(1); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->n_field[0].n_val = c; + return t; + } + +nodeptr c_str_leaf(type, loc_model, c) +int type; +nodeptr loc_model; +char *c; + { + register nodeptr t; + + t = NewNode(1); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->n_field[0].n_str = c; + return t; + } + +nodeptr i_str_leaf(type, loc_model, c, d) +int type; +nodeptr loc_model; +char *c; +int d; + { + register nodeptr t; + + t = NewNode(2); + t->n_type = type; + t->n_file = loc_model->n_file; + t->n_line = loc_model->n_line; + t->n_col = loc_model->n_col; + t->n_field[0].n_str = c; + t->n_field[1].n_val = d; + return t; + } + diff --git a/src/icont/tree.h b/src/icont/tree.h new file mode 100644 index 0000000..7950c81 --- /dev/null +++ b/src/icont/tree.h @@ -0,0 +1,109 @@ +/* + * Structure of a tree node. + */ + +typedef struct node *nodeptr; +#define YYSTYPE nodeptr + +union field { + long n_val; /* integer-valued fields */ + char *n_str; /* string-valued fields */ + nodeptr n_ptr; /* subtree pointers */ + }; + +struct node { + int n_type; /* node type */ + char *n_file; /* name of file containing source program */ + int n_line; /* line number in source program */ + int n_col; /* column number in source program */ + union field n_field[1]; /* variable-content fields */ + }; + +#define NewNode(size) (struct node *)alloc(\ + (sizeof(struct node) + (size-1) * sizeof(union field))) + +/* + * Macros to access fields of parse tree nodes. + */ + +#define TType(t) t->n_type +#define File(t) t->n_file +#define Line(t) t->n_line +#define Col(t) t->n_col +#define Tree0(t) t->n_field[0].n_ptr +#define Tree1(t) t->n_field[1].n_ptr +#define Tree2(t) t->n_field[2].n_ptr +#define Tree3(t) t->n_field[3].n_ptr +#define Val0(t) t->n_field[0].n_val +#define Val1(t) t->n_field[1].n_val +#define Val2(t) t->n_field[2].n_val +#define Val3(t) t->n_field[3].n_val +#define Val4(t) t->n_field[4].n_val +#define Str0(t) t->n_field[0].n_str +#define Str1(t) t->n_field[1].n_str +#define Str2(t) t->n_field[2].n_str +#define Str3(t) t->n_field[3].n_str + +/* + * External declarations. + */ + +extern nodeptr yylval; /* parser's current token value */ +extern struct node tok_loc; /* "model" token holding current location */ + +/* + * Node types. + */ + +#define N_Activat 1 /* activation control structure */ +#define N_Alt 2 /* alternation operator */ +#define N_Augop 3 /* augmented operator */ +#define N_Bar 4 /* generator control structure */ +#define N_Binop 5 /* other binary operator */ +#define N_Break 6 /* break statement */ +#define N_Case 7 /* case statement */ +#define N_Ccls 8 /* case clause */ +#define N_Clist 9 /* list of case clauses */ +#define N_Conj 10 /* conjunction operator */ +#define N_Create 11 /* create control structure */ +#define N_Cset 12 /* cset literal */ +#define N_Elist 14 /* list of expressions */ +#define N_Empty 15 /* empty expression or statement */ +#define N_Field 16 /* record field reference */ +#define N_Id 17 /* identifier token */ +#define N_If 18 /* if-then-else statement */ +#define N_Int 19 /* integer literal */ +#define N_Invok 20 /* invocation */ +#define N_Key 21 /* keyword */ +#define N_Limit 22 /* LIMIT control structure */ +#define N_List 23 /* [ ... ] style list */ +#define N_Loop 24 /* while, until, every, or repeat */ +#define N_Not 25 /* not prefix control structure */ +#define N_Next 26 /* next statement */ +#define N_Op 27 /* operator token */ +#define N_Proc 28 /* procedure */ +#define N_Real 29 /* real literal */ +#define N_Res 30 /* reserved word token */ +#define N_Ret 31 /* fail, return, or succeed */ +#define N_Scan 32 /* scan-using statement */ +#define N_Sect 33 /* s[i:j] (section) */ +#define N_Slist 34 /* list of statements */ +#define N_Str 35 /* string literal */ +#define N_Susp 36 /* suspend statement */ +#define N_To 37 /* TO operator */ +#define N_ToBy 38 /* TO-BY operator */ +#define N_Unop 39 /* unary operator */ +#define N_Apply 40 /* procedure application */ + + +/* + * Macros for constructing basic nodes. + */ + +#define CsetNode(a,b) i_str_leaf(N_Cset,&tok_loc,a,b) +#define IdNode(a) c_str_leaf(N_Id,&tok_loc,a) +#define IntNode(a) c_str_leaf(N_Int,&tok_loc,a) +#define OpNode(a) int_leaf(N_Op,&tok_loc,optab[a].tok.t_type) +#define RealNode(a) c_str_leaf(N_Real,&tok_loc,a) +#define ResNode(a) int_leaf(N_Res,&tok_loc,a) +#define StrNode(a,b) i_str_leaf(N_Str,&tok_loc,a,b) diff --git a/src/icont/tsym.c b/src/icont/tsym.c new file mode 100644 index 0000000..1d0f16c --- /dev/null +++ b/src/icont/tsym.c @@ -0,0 +1,519 @@ +/* + * tsym.c -- functions for symbol table management. + */ + +#include "../h/gsupport.h" +#include "tproto.h" +#include "tglobals.h" +#include "ttoken.h" +#include "tsym.h" +#include "keyword.h" +#include "lfile.h" + +/* + * Prototypes. + */ + +static struct tgentry *alcglob + (struct tgentry *blink, char *name,int flag,int nargs); +static struct tcentry *alclit + (struct tcentry *blink, char *name, int len,int flag); +static struct tlentry *alcloc + (struct tlentry *blink, char *name,int flag); +static struct tcentry *clookup (char *id,int flag); +static struct tgentry *glookup (char *id); +static struct tlentry *llookup (char *id); +static void putglob + (char *id,int id_type, int n_args); + +#ifdef DeBugTrans + void cdump (void); + void gdump (void); + void ldump (void); +#endif /* DeBugTrans */ + + +/* + * Keyword table. + */ + +struct keyent { + char *keyname; + int keyid; + }; + +#define KDef(p,n) Lit(p), n, +static struct keyent keytab[] = { +#include "../h/kdefs.h" + NULL, -1 +}; + +/* + * loc_init - clear the local and constant symbol tables. + */ + +void loc_init() + { + struct tlentry *lptr, *lptr1; + struct tcentry *cptr, *cptr1; + int i; + + /* + * Clear local table, freeing entries. + */ + for (i = 0; i < lhsize; i++) { + for (lptr = lhash[i]; lptr != NULL; lptr = lptr1) { + lptr1 = lptr->l_blink; + free((char *)lptr); + } + lhash[i] = NULL; + } + lfirst = NULL; + llast = NULL; + + /* + * Clear constant table, freeing entries. + */ + for (i = 0; i < lchsize; i++) { + for (cptr = chash[i]; cptr != NULL; cptr = cptr1) { + cptr1 = cptr->c_blink; + free((char *)cptr); + } + chash[i] = NULL; + } + cfirst = NULL; + clast = NULL; + } + +/* + * install - put an identifier into the global or local symbol table. + * The basic idea here is to look in the right table and install + * the identifier if it isn't already there. Some semantic checks + * are performed. + */ +void install(name, flag, argcnt) +char *name; +int flag, argcnt; + { + union { + struct tgentry *gp; + struct tlentry *lp; + } p; + + switch (flag) { + case F_Global: /* a variable in a global declaration */ + if ((p.gp = glookup(name)) == NULL) + putglob(name, flag, argcnt); + else + p.gp->g_flag |= flag; + break; + + case F_Proc|F_Global: /* procedure declaration */ + case F_Record|F_Global: /* record declaration */ + case F_Builtin|F_Global: /* external declaration */ + if ((p.gp = glookup(name)) == NULL) + putglob(name, flag, argcnt); + else if ((p.gp->g_flag & (~F_Global)) == 0) { /* superfluous global + declaration for + record or proc */ + p.gp->g_flag |= flag; + p.gp->g_nargs = argcnt; + } + else /* the user can't make up his mind */ + tfatal("inconsistent redeclaration", name); + break; + + case F_Static: /* static declaration */ + case F_Dynamic: /* local declaration (possibly implicit?) */ + case F_Argument: /* formal parameter */ + if ((p.lp = llookup(name)) == NULL) + putloc(name,flag); + else if (p.lp->l_flag == flag) /* previously declared as same type */ + tfatal("redeclared identifier", name); + else /* previously declared as different type */ + tfatal("inconsistent redeclaration", name); + break; + + default: + tsyserr("install: unrecognized symbol table flag."); + } + } + +/* + * putloc - make a local symbol table entry and return the index + * of the entry in lhash. alcloc does the work if there is a collision. + */ +int putloc(id,id_type) +char *id; +int id_type; + { + register struct tlentry *ptr; + + if ((ptr = llookup(id)) == NULL) { /* add to head of hash chain */ + ptr = lhash[lhasher(id)]; + lhash[lhasher(id)] = alcloc(ptr, id, id_type); + return lhash[lhasher(id)]->l_index; + } + return ptr->l_index; + } + +/* + * putglob makes a global symbol table entry. alcglob does the work if there + * is a collision. + */ + +static void putglob(id, id_type, n_args) +char *id; +int id_type, n_args; + { + register struct tgentry *ptr; + + if ((ptr = glookup(id)) == NULL) { /* add to head of hash chain */ + ptr = ghash[ghasher(id)]; + ghash[ghasher(id)] = alcglob(ptr, id, id_type, n_args); + } + } + +/* + * putlit makes a constant symbol table entry and returns the table "index" + * of the constant. alclit does the work if there is a collision. + */ +int putlit(id, idtype, len) +char *id; +int len, idtype; + { + register struct tcentry *ptr; + + if ((ptr = clookup(id,idtype)) == NULL) { /* add to head of hash chain */ + ptr = chash[chasher(id)]; + chash[chasher(id)] = alclit(ptr, id, len, idtype); + return chash[chasher(id)]->c_index; + } + return ptr->c_index; + } + +/* + * llookup looks up id in local symbol table and returns pointer to + * to it if found or NULL if not present. + */ + +static struct tlentry *llookup(id) +char *id; + { + register struct tlentry *ptr; + + ptr = lhash[lhasher(id)]; + while (ptr != NULL && ptr->l_name != id) + ptr = ptr->l_blink; + return ptr; + } + +/* + * glookup looks up id in global symbol table and returns pointer to + * to it if found or NULL if not present. + */ +static struct tgentry *glookup(id) +char *id; + { + register struct tgentry *ptr; + + ptr = ghash[ghasher(id)]; + while (ptr != NULL && ptr->g_name != id) { + ptr = ptr->g_blink; + } + return ptr; + } + +/* + * clookup looks up id in constant symbol table and returns pointer to + * to it if found or NULL if not present. + */ +static struct tcentry *clookup(id,flag) +char *id; +int flag; + { + register struct tcentry *ptr; + + ptr = chash[chasher(id)]; + while (ptr != NULL && (ptr->c_name != id || ptr->c_flag != flag)) + ptr = ptr->c_blink; + + return ptr; + } + +/* + * klookup looks up keyword named by id in keyword table and returns + * its number (keyid). + */ +int klookup(id) +register char *id; + { + register struct keyent *kp; + + for (kp = keytab; kp->keyid >= 0; kp++) + if (strcmp(kp->keyname,id) == 0) + return (kp->keyid); + + return 0; + } + +#ifdef DeBugTrans +/* + * ldump displays local symbol table to stdout. + */ + +void ldump() + { + register int i; + register struct tlentry *lptr; + int n; + + if (llast == NULL) + n = 0; + else + n = llast->l_index + 1; + fprintf(stderr,"Dump of local symbol table (%d entries)\n", n); + fprintf(stderr," loc blink id (name) flags\n"); + for (i = 0; i < lhsize; i++) + for (lptr = lhash[i]; lptr != NULL; lptr = lptr->l_blink) + fprintf(stderr,"%5d %5d %5d %20s %7o\n", lptr->l_index, + lptr->l_blink, lptr->l_name, lptr->l_name, lptr->l_flag); + fflush(stderr); + + } + +/* + * gdump displays global symbol table to stdout. + */ + +void gdump() + { + register int i; + register struct tgentry *gptr; + int n; + + if (glast == NULL) + n = 0; + else + n = glast->g_index + 1; + fprintf(stderr,"Dump of global symbol table (%d entries)\n", n); + fprintf(stderr," loc blink id (name) flags nargs\n"); + for (i = 0; i < ghsize; i++) + for (gptr = ghash[i]; gptr != NULL; gptr = gptr->g_blink) + fprintf(stderr,"%5d %5d %5d %20s %7o %8d\n", gptr->g_index, + gptr->g_blink, gptr->g_name, gptr->g_name, + gptr->g_flag, gptr->g_nargs); + fflush(stderr); + } + +/* + * cdump displays constant symbol table to stdout. + */ + +void cdump() + { + register int i; + register struct tcentry *cptr; + int n; + + if (clast == NULL) + n = 0; + else + n = clast->c_index + 1; + fprintf(stderr,"Dump of constant symbol table (%d entries)\n", n); + fprintf(stderr," loc blink id (name) flags\n"); + for (i = 0; i < lchsize; i++) + for (cptr = chash[i]; cptr != NULL; cptr = cptr->c_blink) + fprintf(stderr,"%5d %5d %5d %20s %7o\n", cptr->c_index, + cptr->c_blink, cptr->c_name, cptr->c_name, cptr->c_flag); + fflush(stderr); + } +#endif /* DeBugTrans */ + +/* + * alcloc allocates a local symbol table entry, fills in fields with + * specified values and returns the new entry. + */ +static struct tlentry *alcloc(blink, name, flag) +struct tlentry *blink; +char *name; +int flag; + { + register struct tlentry *lp; + + lp = NewStruct(tlentry); + lp->l_blink = blink; + lp->l_name = name; + lp->l_flag = flag; + lp->l_next = NULL; + if (lfirst == NULL) { + lfirst = lp; + lp->l_index = 0; + } + else { + llast->l_next = lp; + lp->l_index = llast->l_index + 1; + } + llast = lp; + return lp; + } + +/* + * alcglob allocates a global symbol table entry, fills in fields with + * specified values and returns offset of new entry. + */ +static struct tgentry *alcglob(blink, name, flag, nargs) +struct tgentry *blink; +char *name; +int flag, nargs; + { + register struct tgentry *gp; + + gp = NewStruct(tgentry); + gp->g_blink = blink; + gp->g_name = name; + gp->g_flag = flag; + gp->g_nargs = nargs; + gp->g_next = NULL; + if (gfirst == NULL) { + gfirst = gp; + gp->g_index = 0; + } + else { + glast->g_next = gp; + gp->g_index = glast->g_index + 1; + } + glast = gp; + return gp; + } + +/* + * alclit allocates a constant symbol table entry, fills in fields with + * specified values and returns the new entry. + */ +static struct tcentry *alclit(blink, name, len, flag) +struct tcentry *blink; +char *name; +int len, flag; + { + register struct tcentry *cp; + + cp = NewStruct(tcentry); + cp->c_blink = blink; + cp->c_name = name; + cp->c_length = len; + cp->c_flag = flag; + cp->c_next = NULL; + if (cfirst == NULL) { + cfirst = cp; + cp->c_index = 0; + } + else { + clast->c_next = cp; + cp->c_index = clast->c_index + 1; + } + clast = cp; + return cp; + } + +/* + * lout dumps local symbol table to fd, which is a .u1 file. + */ +void lout(fd) +FILE *fd; + { + register struct tlentry *lp; + + for (lp = lfirst; lp != NULL; lp = lp->l_next) + writecheck(fprintf(fd, "\tlocal\t%d,%06o,%s\n", + lp->l_index, lp->l_flag, lp->l_name)); + } + +/* + * constout dumps constant symbol table to fd, which is a .u1 file. + */ +void constout(fd) +FILE *fd; + { + register int l; + register char *c; + register struct tcentry *cp; + + for (cp = cfirst; cp != NULL; cp = cp->c_next) { + writecheck(fprintf(fd, "\tcon\t%d,%06o", cp->c_index, cp->c_flag)); + if (cp->c_flag & F_IntLit) + writecheck(fprintf(fd,",%d,%s\n",(int)strlen(cp->c_name),cp->c_name)); + else if (cp->c_flag & F_RealLit) + writecheck(fprintf(fd, ",%s\n", cp->c_name)); + else { + c = cp->c_name; + l = cp->c_length; + writecheck(fprintf(fd, ",%d", l)); + while (l--) + writecheck(fprintf(fd, ",%03o", *c++ & 0377)); + writecheck(putc('\n', fd)); + } + } + } + +/* + * rout dumps a record declaration for name to file fd, which is a .u2 file. + */ +void rout(fd,name) +FILE *fd; +char *name; + { + register struct tlentry *lp; + int n; + + if (llast == NULL) + n = 0; + else + n = llast->l_index + 1; + writecheck(fprintf(fd, "record\t%s,%d\n", name, n)); + for (lp = lfirst; lp != NULL; lp = lp->l_next) + writecheck(fprintf(fd, "\t%d,%s\n", lp->l_index, lp->l_name)); + } + +/* + * gout writes various items to fd, which is a .u2 file. These items + * include: implicit status, tracing activation, link directives, + * invocable directives, and the global table. + */ +void gout(fd) +FILE *fd; + { + register char *name; + register struct tgentry *gp; + int n; + struct lfile *lfl; + struct invkl *ivl; + + if (uwarn) + name = "error"; + else + name = "local"; + writecheck(fprintf(fd, "impl\t%s\n", name)); + if (trace) + writecheck(fprintf(fd, "trace\n")); + + lfl = lfiles; + while (lfl) { + writecheck(fprintf(fd,"link\t%s.u1\n",lfl->lf_name)); + lfl = lfl->lf_link; + } + lfiles = 0; + + for (ivl = invkls; ivl != NULL; ivl = ivl->iv_link) + writecheck(fprintf(fd, "invocable\t%s\n", ivl->iv_name)); + invkls = NULL; + + if (glast == NULL) + n = 0; + else + n = glast->g_index + 1; + writecheck(fprintf(fd, "global\t%d\n", n)); + for (gp = gfirst; gp != NULL; gp = gp->g_next) + writecheck(fprintf(fd, "\t%d,%06o,%s,%d\n", gp->g_index, gp->g_flag, + gp->g_name, gp->g_nargs)); + } diff --git a/src/icont/tsym.h b/src/icont/tsym.h new file mode 100644 index 0000000..a932345 --- /dev/null +++ b/src/icont/tsym.h @@ -0,0 +1,69 @@ +/* + * Structures for symbol table entries. + */ + +struct tlentry { /* local table entry */ + struct tlentry *l_blink; /* link for bucket chain */ + char *l_name; /* name of variable */ + int l_flag; /* variable flags */ + int l_index; /* "index" of local in table */ + struct tlentry *l_next; /* next local in table */ + }; + +struct tgentry { /* global table entry */ + struct tgentry *g_blink; /* link for bucket chain */ + char *g_name; /* name of variable */ + int g_flag; /* variable flags */ + int g_nargs; /* number of args (procedure) or */ + int g_index; /* "index" of global in table */ + struct tgentry *g_next; /* next global in table */ + }; /* number of fields (record) */ + +struct tcentry { /* constant table entry */ + struct tcentry *c_blink; /* link for bucket chain */ + char *c_name; /* pointer to string */ + int c_length; /* length of string */ + int c_flag; /* type of literal flag */ + int c_index; /* "index" of constant in table */ + struct tcentry *c_next; /* next constant in table */ + }; + +/* + * Flag values. + */ + +#define F_Global 01 /* variable declared global externally */ +#define F_Proc 04 /* procedure */ +#define F_Record 010 /* record */ +#define F_Dynamic 020 /* variable declared local dynamic */ +#define F_Static 040 /* variable declared local static */ +#define F_Builtin 0100 /* identifier refers to built-in procedure */ +#define F_ImpError 0400 /* procedure has default error */ +#define F_Argument 01000 /* variable is a formal parameter */ +#define F_IntLit 02000 /* literal is an integer */ +#define F_RealLit 04000 /* literal is a real */ +#define F_StrLit 010000 /* literal is a string */ +#define F_CsetLit 020000 /* literal is a cset */ + +/* + * Symbol table region pointers. + */ + +extern struct tlentry **lhash; /* hash area for local table */ +extern struct tgentry **ghash; /* hash area for global table */ +extern struct tcentry **chash; /* hash area for constant table */ + +extern struct tlentry *lfirst; /* first local table entry */ +extern struct tlentry *llast; /* last local table entry */ +extern struct tcentry *cfirst; /* first constant table entry */ +extern struct tcentry *clast; /* last constant table entry */ +extern struct tgentry *gfirst; /* first global table entry */ +extern struct tgentry *glast; /* last global table entry */ + +/* + * Hash functions for symbol tables. + */ + +#define ghasher(x) (((word)x)&gmask) /* global symbol table */ +#define lhasher(x) (((word)x)&lmask) /* local symbol table */ +#define chasher(x) (((word)x)&cmask) /* constant symbol table */ diff --git a/src/icont/ttoken.h b/src/icont/ttoken.h new file mode 100644 index 0000000..1e95e98 --- /dev/null +++ b/src/icont/ttoken.h @@ -0,0 +1,111 @@ +# define IDENT 257 +# define INTLIT 258 +# define REALLIT 259 +# define STRINGLIT 260 +# define CSETLIT 261 +# define EOFX 262 +# define BREAK 263 +# define BY 264 +# define CASE 265 +# define CREATE 266 +# define DEFAULT 267 +# define DO 268 +# define ELSE 269 +# define END 270 +# define EVERY 271 +# define FAIL 272 +# define GLOBAL 273 +# define IF 274 +# define INITIAL 275 +# define INVOCABLE 276 +# define LINK 277 +# define LOCAL 278 +# define NEXT 279 +# define NOT 280 +# define OF 281 +# define PROCEDURE 282 +# define RECORD 283 +# define REPEAT 284 +# define RETURN 285 +# define STATIC 286 +# define SUSPEND 287 +# define THEN 288 +# define TO 289 +# define UNTIL 290 +# define WHILE 291 +# define BANG 292 +# define MOD 293 +# define AUGMOD 294 +# define AND 295 +# define AUGAND 296 +# define STAR 297 +# define AUGSTAR 298 +# define INTER 299 +# define AUGINTER 300 +# define PLUS 301 +# define AUGPLUS 302 +# define UNION 303 +# define AUGUNION 304 +# define MINUS 305 +# define AUGMINUS 306 +# define DIFF 307 +# define AUGDIFF 308 +# define DOT 309 +# define SLASH 310 +# define AUGSLASH 311 +# define ASSIGN 312 +# define SWAP 313 +# define NMLT 314 +# define AUGNMLT 315 +# define REVASSIGN 316 +# define REVSWAP 317 +# define SLT 318 +# define AUGSLT 319 +# define SLE 320 +# define AUGSLE 321 +# define NMLE 322 +# define AUGNMLE 323 +# define NMEQ 324 +# define AUGNMEQ 325 +# define SEQ 326 +# define AUGSEQ 327 +# define EQUIV 328 +# define AUGEQUIV 329 +# define NMGT 330 +# define AUGNMGT 331 +# define NMGE 332 +# define AUGNMGE 333 +# define SGT 334 +# define AUGSGT 335 +# define SGE 336 +# define AUGSGE 337 +# define QMARK 338 +# define AUGQMARK 339 +# define AT 340 +# define AUGAT 341 +# define BACKSLASH 342 +# define CARET 343 +# define AUGCARET 344 +# define BAR 345 +# define CONCAT 346 +# define AUGCONCAT 347 +# define LCONCAT 348 +# define AUGLCONCAT 349 +# define TILDE 350 +# define NMNE 351 +# define AUGNMNE 352 +# define SNE 353 +# define AUGSNE 354 +# define NEQUIV 355 +# define AUGNEQUIV 356 +# define LPAREN 357 +# define RPAREN 358 +# define PCOLON 359 +# define COMMA 360 +# define MCOLON 361 +# define COLON 362 +# define SEMICOL 363 +# define LBRACK 364 +# define RBRACK 365 +# define LBRACE 366 +# define RBRACE 367 diff --git a/src/icont/tunix.c b/src/icont/tunix.c new file mode 100644 index 0000000..9478403 --- /dev/null +++ b/src/icont/tunix.c @@ -0,0 +1,420 @@ +/* + * tunix.c - user interface for Unix. + */ + +#include "../h/gsupport.h" +#include "../h/version.h" +#include "tproto.h" +#include "tglobals.h" + +static void execute (char *ofile, char *efile, char *args[]); +static void usage (void); +static char *libpath (char *prog, char *envname); + +static void txrun(char *(*func)(FILE*, char*), char *source, char *args[]); +static char *copyfile(FILE *f, char *srcfile); +static char *savefile(FILE *f, char *srcprog); +static void cleanup(void); + +static char **rfiles; /* list of files removed by cleanup() */ + +/* + * for old method of hardwiring iconx path; not normally used. + */ +static char patchpath[MaxPath+18] = "%PatchStringHere->"; + +/* + * getopt() variables + */ +extern int optind; /* index into parent argv vector */ +extern int optopt; /* character checked for validity */ +extern char *optarg; /* argument associated with option */ + +/* + * main program + */ +int main(int argc, char *argv[]) { + int nolink = 0; /* suppress linking? */ + int errors = 0; /* translator and linker errors */ + char **tfiles, **tptr; /* list of files to translate */ + char **lfiles, **lptr; /* list of files to link */ + char **rptr; /* list of files to remove */ + char *efile = NULL; /* stderr file */ + char buf[MaxPath]; /* file name construction buffer */ + int c, n; + char ch; + struct fileparts *fp; + + /* + * Initialize globals. + */ + initglob(); /* general global initialization */ + ipath = libpath(argv[0], "IPATH"); /* set library search paths */ + lpath = libpath(argv[0], "LPATH"); + if (strlen(patchpath) > 18) + iconxloc = patchpath + 18; /* use stated iconx path if patched */ + else + iconxloc = relfile(argv[0], "/../iconx"); /* otherwise infer it */ + + /* + * Process options. + * IMPORTANT: When making changes here, + * also update usage() function and man page. + */ + while ((c = getopt(argc, argv, "+ce:f:o:stuv:ELNP:VX:")) != EOF) + switch (c) { + case 'c': /* -c: compile only (no linking) */ + nolink = 1; + break; + case 'e': /* -e file: [undoc] redirect stderr */ + efile = optarg; + break; + case 'f': /* -f features: enable features */ + if (strchr(optarg, 's') || strchr(optarg, 'a')) + strinv = 1; /* this is the only icont feature */ + break; + case 'o': /* -o file: name output file */ + ofile = optarg; + break; + case 's': /* -s: suppress informative messages */ + silent = 1; + verbose = 0; + break; + case 't': /* -t: turn on procedure tracing */ + trace = -1; + break; + case 'u': /* -u: warn about undeclared ids */ + uwarn = 1; + break; + case 'v': /* -v n: set verbosity level */ + if (sscanf(optarg, "%d%c", &verbose, &ch) != 1) + quitf("bad operand to -v option: %s", optarg); + if (verbose == 0) + silent = 1; + break; + case 'E': /* -E: preprocess only */ + pponly = 1; + nolink = 1; + break; + case 'P': /* -P program: execute from argument */ + txrun(savefile, optarg, &argv[optind]); + break; /*NOTREACHED*/ + case 'N': /* -N: don't embed iconx path */ + iconxloc = ""; + break; + case 'V': /* -V: print version information */ + fprintf(stderr, "%s (%s, %s)\n", Version, Config, __DATE__); + if (optind == argc) + exit(0); + break; + case 'X': /* -X srcfile: execute single srcfile */ + txrun(copyfile, optarg, &argv[optind]); + break; /*NOTREACHED*/ + + #ifdef DeBugLinker + case 'L': /* -L: enable linker debugging */ + Dflag = 1; + break; + #endif /* DeBugLinker */ + + default: + case 'x': /* -x illegal until after file list */ + usage(); + } + + /* + * If argv[0] ends in "icon" (instead of "icont" or anything else), + * process as "icon [options] sourcefile [arguments]" scripting shortcut. + */ + n = strlen(argv[0]); + if (n >= 4 && strcmp(argv[0]+n-4, "icon") == 0) { + if (optind < argc) + txrun(copyfile, argv[optind], &argv[optind+1]); + else + usage(); + } + + /* + * Allocate space for lists of file names. + */ + n = argc - optind + 1; + tptr = tfiles = alloc(n * sizeof(char *)); + lptr = lfiles = alloc(n * sizeof(char *)); + rptr = rfiles = alloc(2 * n * sizeof(char *)); + + /* + * Scan file name arguments. + */ + while (optind < argc) { + if (strcmp(argv[optind], "-x") == 0) /* stop at -x */ + break; + else if (strcmp(argv[optind], "-") == 0) { + *tptr++ = "-"; /* "-" means standard input */ + *lptr++ = *rptr++ = "stdin.u1"; + *rptr++ = "stdin.u2"; + } + else { + fp = fparse(argv[optind]); /* parse file name */ + if (*fp->ext == '\0' || smatch(fp->ext, SourceSuffix)) { + makename(buf, SourceDir, argv[optind], SourceSuffix); + *tptr++ = salloc(buf); /* translate the .icn file */ + makename(buf, TargetDir, argv[optind], U1Suffix); + *lptr++ = *rptr++ = salloc(buf); /* link & remove .u1 */ + makename(buf, TargetDir, argv[optind], U2Suffix); + *rptr++ = salloc(buf); /* also remove .u2 */ + } + else if (smatch(fp->ext, U1Suffix) || smatch(fp->ext, U2Suffix) + || smatch(fp->ext, USuffix)) { + makename(buf, TargetDir, argv[optind], U1Suffix); + *lptr++ = salloc(buf); + } + else + quitf("bad argument %s", argv[optind]); + } + optind++; + } + + *tptr = *lptr = *rptr = NULL; /* terminate filename lists */ + if (lptr == lfiles) + usage(); /* error -- no files named */ + + /* + * Translate .icn files to make .u1 and .u2 files. + */ + if (tptr > tfiles) { + if (!pponly) + report("Translating"); + errors = trans(tfiles, TargetDir); + if (errors > 0) /* exit if errors seen */ + exit(EXIT_FAILURE); + } + + /* + * Link .u1 and .u2 files to make an executable. + */ + if (nolink) /* exit if no linking wanted */ + exit(EXIT_SUCCESS); + + if (ofile == NULL) { /* if no -o file, synthesize a name */ + ofile = salloc(makename(buf, TargetDir, lfiles[0], IcodeSuffix)); + } + else { /* add extension in necessary */ + fp = fparse(ofile); + if (*fp->ext == '\0' && *IcodeSuffix != '\0') /* if no ext given */ + ofile = salloc(makename(buf, NULL, ofile, IcodeSuffix)); + } + + report("Linking"); + errors = ilink(lfiles, ofile); /* link .u files to make icode file */ + + /* + * Finish by removing intermediate files. + * Execute the linked program if so requested and if there were no errors. + */ + cleanup(); /* delete intermediate files */ + if (errors > 0) { /* exit if linker errors seen */ + remove(ofile); + exit(EXIT_FAILURE); + } + if (optind < argc) { + report("Executing"); + execute (ofile, efile, argv + optind + 1); + } + exit(EXIT_SUCCESS); + return 0; + } + +/* + * execute - execute iconx to run the icon program + */ +static void execute(char *ofile, char *efile, char *args[]) { + int n; + char **argv, **p; + char buf[MaxPath+10]; + + /* + * Build argument vector. + */ + for (n = 0; args[n] != NULL; n++) /* count arguments */ + ; + p = argv = alloc((n + 5) * sizeof(char *)); + + *p++ = ofile; /* pass icode file name */ + while ((*p++ = *args++) != 0) /* copy args into argument vector */ + ; + *p = NULL; + + /* + * Redirect stderr if requested. + */ + if (efile != NULL) { + close(fileno(stderr)); + if (strcmp(efile, "-") == 0) + dup(fileno(stdout)); + else if (freopen(efile, "w", stderr) == NULL) + quitf("could not redirect stderr to %s\n", efile); + } + + /* + * Export $ICONX to specify the path to iconx. + */ + sprintf(buf, "ICONX=%s", iconxloc); + putenv(buf); + + /* + * Execute the generated program. + */ + execv(ofile, argv); + quitf("could not execute %s", ofile); + } + +void report(char *s) { + char *c = (strchr(s, '\n') ? "" : ":\n") ; + if (!silent) + fprintf(stderr, "%s%s", s, c); + } + +/* + * Print a usage message and abort the run. + */ +static void usage(void) { + fprintf(stderr, "usage: icon sourcefile [args]\n"); + fprintf(stderr, " icon -P 'program' [args]\n"); + fprintf(stderr, " icont %s\n", + "[-cstuENV] [-f s] [-o ofile] [-v i] file ... [-x args]"); + exit(EXIT_FAILURE); + } + +/* + * Return path after appending lib directory. + */ +static char *libpath(char *prog, char *envname) { + char buf[1000], *s; + + s = getenv(envname); + if (s != NULL) + #if CYGWIN + cygwin_win32_to_posix_path_list(s, buf); + #else /* CYGWIN */ + strcpy(buf, s); + #endif /* CYGWIN */ + else + strcpy(buf, "."); + strcat(buf, ":"); + strcat(buf, relfile(prog, "/../../lib")); + return salloc(buf); + } + +/* + * Translate, link, and execute a source file. + * Does not return under any circumstances. + */ +static void txrun(char *(*func)(FILE*, char*), char *source, char *args[]) { + int omask; + char c1, c2; + char *flist[2], *progname; + char srcfile[MaxPath], u1[MaxPath], u2[MaxPath]; + char icode[MaxPath], buf[MaxPath + 20]; + static char abet[] = "abcdefghijklmnopqrstuvwxyz"; + FILE *f; + + silent = 1; /* don't issue commentary while translating */ + uwarn = 1; /* do diagnose undeclared identifiers */ + omask = umask(0077); /* remember umask; keep /tmp files private */ + + /* + * Invent a file named /tmp/innnnnxx.icn. + */ + srand(time(NULL)); + c1 = abet[rand() % (sizeof(abet) - 1)]; + c2 = abet[rand() % (sizeof(abet) - 1)]; + sprintf(srcfile, "/tmp/i%d%c%c.icn", getpid(), c1, c2); + + /* + * Copy the source code to the temporary file. + */ + f = fopen(srcfile, "w"); + if (f == NULL) + quitf("cannot open for writing: %s", srcfile); + progname = func(f, source); + fclose(f); + + /* + * Derive other names and arrange for cleanup on exit. + */ + rfiles = alloc(5 * sizeof(char *)); + rfiles[0] = srcfile; + makename(rfiles[1] = u1, NULL, srcfile, U1Suffix); + makename(rfiles[2] = u2, NULL, srcfile, U2Suffix); + makename(rfiles[3] = icode, NULL, srcfile, IcodeSuffix); + rfiles[4] = NULL; + atexit(cleanup); + + /* + * Translate to produce .u1 and .u2 files. + */ + flist[0] = srcfile; + flist[1] = NULL; + if (trans(flist, SourceDir) > 0) + exit(EXIT_FAILURE); + + /* + * Link to make an icode file. + */ + flist[0] = u1; + if (ilink(flist, icode) > 0) + exit(EXIT_FAILURE); + + /* + * Execute the icode file. + */ + rfiles[3] = NULL; /* don't delete icode yet */ + cleanup(); /* but delete the others */ + sprintf(buf, "ICODE_TEMP=%s:%s", icode, progname); + putenv(buf); /* tell iconx to delete icode */ + umask(omask); /* reset original umask */ + execute(icode, NULL, args); /* execute the program */ + quitf("could not execute %s", icode); + } + +/* + * Dump a string to a file, prefixed by $line 0 "[inline]". + */ +static char *savefile(FILE *f, char *srcprog) { + static char *progname = "[inline]"; + fprintf(f, "$line 0 \"%s\"\n", progname); + fwrite(srcprog, 1, strlen(srcprog), f); + return progname; + } + +/* + * Copy a source file for later translation, adding $line 0 "filename". + */ +static char *copyfile(FILE *f, char *srcfile) { + int c; + FILE *e; + + if (strcmp(srcfile, "-") == 0) { + e = stdin; + srcfile = "stdin"; + } + else { + if ((e = fopen(srcfile, "r")) == NULL) + quitf("cannot open: %s", srcfile); + } + fprintf(f, "$line 0 \"%s\"\n", srcfile); + while ((c = getc(e)) != EOF) + putc(c, f); + fclose(e); + return srcfile; + } + +/* + * Deletes the files listed in rfiles[]. + */ +static void cleanup(void) { + char **p; + + for (p = rfiles; *p; p++) + remove(*p); + } diff --git a/src/icont/util.c b/src/icont/util.c new file mode 100644 index 0000000..3a54901 --- /dev/null +++ b/src/icont/util.c @@ -0,0 +1,93 @@ +/* + * util.c -- general utility functions. + */ + +#include "../h/gsupport.h" +#include "tproto.h" +#include "tglobals.h" +#include "tree.h" + +extern int optind; +extern char *ofile; + +/* + * Information about Icon functions. + */ + +/* + * Names of Icon functions. + */ +char *ftable[] = { +#define FncDef(p,n) Lit(p), +#define FncDefV(p) Lit(p), +#include "../h/fdefs.h" +#undef FncDef +#undef FncDefV + }; + +int ftbsize = sizeof(ftable) / sizeof(char *); + +/* + * tcalloc - allocate and zero m*n bytes + */ +pointer tcalloc(m, n) +unsigned int m, n; + { + pointer a; + + if ((a = calloc(m, n)) == 0) + quit("out of memory"); + return a; + } + +/* + * trealloc - realloc a table making it half again larger and zero the + * new part of the table. + */ +pointer trealloc(table, tblfree, size, unit_size, min_units, tbl_name) +pointer table; /* table to be realloc()ed */ +pointer tblfree; /* reference to table free pointer if there is one */ +unsigned int *size; /* size of table */ +int unit_size; /* number of bytes in a unit of the table */ +int min_units; /* the minimum number of units that must be allocated. */ +char *tbl_name; /* name of the table */ + { + word new_size; + word num_bytes; + word free_offset; + word i; + char *new_tbl; + + new_size = (*size * 3) / 2; + if (new_size - *size < min_units) + new_size = *size + min_units; + num_bytes = new_size * unit_size; + + if (tblfree != NULL) + free_offset = DiffPtrs(*(char **)tblfree, (char *)table); + + if ((new_tbl = realloc(table, (unsigned)num_bytes)) == 0) + quitf("out of memory for %s", tbl_name); + + for (i = *size * unit_size; i < num_bytes; ++i) + new_tbl[i] = 0; + + *size = new_size; + if (tblfree != NULL) + *(char **)tblfree = (char *)(new_tbl + free_offset); + + return (pointer)new_tbl; + } + + +/* + * round2 - round an integer up to the next power of 2. + */ +unsigned int round2(n) +unsigned int n; + { + unsigned int b = 1; + while (b < n) + b <<= 1; + return b; + } diff --git a/src/preproc/Makefile b/src/preproc/Makefile new file mode 100644 index 0000000..c3d17ed --- /dev/null +++ b/src/preproc/Makefile @@ -0,0 +1,34 @@ +include ../../Makedefs + +POBJS = pout.o pchars.o perr.o pmem.o bldtok.o macro.o preproc.o evaluate.o\ + files.o gettok.o pinit.o + +COBJS= ../common/getopt.o ../common/time.o ../common/strtbl.o ../common/alloc.o + +ICOBJS= getopt.o time.o strtbl.o alloc.o + +OBJS= $(POBJS) $(COBJS) + +DOT_H = preproc.h pproto.h ptoken.h ../h/define.h ../h/config.h\ + ../h/typedefs.h ../h/mproto.h + +common: + cd ../common; $(MAKE) $(ICOBJS) + $(MAKE) pp + +pp: pmain.o $(OBJS) + $(CC) -o pp pmain.o $(OBJS) + +pmain.o: $(DOT_H) +p_out.o: $(DOT_H) +pchars.o: $(DOT_H) +p_err.o: $(DOT_H) +pmem.o: $(DOT_H) +pstring.o: $(DOT_H) +bldtok.o: $(DOT_H) +macro.o: $(DOT_H) +preproc.o: $(DOT_H) +evaluate.o: $(DOT_H) +files.o: $(DOT_H) +gettok.o: $(DOT_H) +p_init.o: $(DOT_H) diff --git a/src/preproc/README b/src/preproc/README new file mode 100644 index 0000000..35d6a23 --- /dev/null +++ b/src/preproc/README @@ -0,0 +1,7 @@ +This directory contains files for building pp, a ANSI-C preprocessor for +C (with some extensions). pp itself is not needed to build the Icon +compiler system -- the files here are automatically incorporated in +rtt. + +However, if you want to build a stand-alone version of pp for +some other use, the Makefile here will do it. diff --git a/src/preproc/bldtok.c b/src/preproc/bldtok.c new file mode 100644 index 0000000..7eafad9 --- /dev/null +++ b/src/preproc/bldtok.c @@ -0,0 +1,766 @@ +/* + * This file contains routines for building tokens out of characters from a + * "character source". This source is the top element on the source stack. + */ +#include "../preproc/preproc.h" +#include "../preproc/ptoken.h" + +/* + * Prototypes for static functions. + */ +static int pp_tok_id (char *s); +static struct token *chck_wh_sp (struct char_src *cs); +static struct token *pp_number (void); +static struct token *char_str (int delim, int tok_id); +static struct token *hdr_tok (int delim, int tok_id, struct char_src *cs); + +int whsp_image = NoSpelling; /* indicate what is in white space tokens */ +struct token *zero_tok; /* token for literal 0 */ +struct token *one_tok; /* token for literal 1 */ + +#include "../preproc/pproto.h" + +/* + * IsWhSp(c) - true if c is a white space character. + */ +#define IsWhSp(c) (c == ' ' || c == '\n' || c == '\t' || c == '\v' || c == '\f') + +/* + * AdvChar() - advance to next character from buffer, filling the buffer + * if needed. + */ +#define AdvChar() \ + if (++next_char == last_char) \ + fill_cbuf(); + +static int line; /* current line number */ +static char *fname; /* current file name */ +static struct str_buf tknize_sbuf; /* string buffer */ + +/* + * List of preprocessing directives and the corresponding token ids. + */ +static struct rsrvd_wrd pp_rsrvd[] = { + PPDirectives + {"if", PpIf}, + {"else", PpElse}, + {"ifdef", PpIfdef}, + {"ifndef", PpIfndef}, + {"elif", PpElif}, + {"endif", PpEndif}, + {"include", PpInclude}, + {"define", PpDefine}, + {"undef", PpUndef}, + {"begdef", PpBegdef}, + {"enddef", PpEnddef}, + {"line", PpLine}, + {"error", PpError}, + {"pragma", PpPragma}, + {NULL, Invalid}}; + +/* + * init_tok - initialize tokenizer. + */ +void init_tok() + { + struct rsrvd_wrd *rw; + static int first_time = 1; + + if (first_time) { + first_time = 0; + init_sbuf(&tknize_sbuf); /* initialize string buffer */ + /* + * install reserved words into the string table + */ + for (rw = pp_rsrvd; rw->s != NULL; ++rw) + rw->s = spec_str(rw->s); + + zero_tok = new_token(PpNumber, spec_str("0"), "", 0); + one_tok = new_token(PpNumber, spec_str("1"), "", 0); + } + } + +/* + * pp_tok_id - see if s in the name of a preprocessing directive. + */ +static int pp_tok_id(s) +char *s; + { + struct rsrvd_wrd *rw; + + for (rw = pp_rsrvd; rw->s != NULL && rw->s != s; ++rw) + ; + return rw->tok_id; + } + +/* + * chk_eq_sign - look ahead to next character to see if it is an equal sign. + * It is used for processing -D options. + */ +int chk_eq_sign() + { + if (*next_char == '=') { + AdvChar(); + return 1; + } + else + return 0; + } + +/* + * chck_wh_sp - If the input is at white space, construct a white space token + * and return it, otherwise return NULL. This function also helps keeps track + * of preprocessor directive boundaries. + */ +static struct token *chck_wh_sp(cs) +struct char_src *cs; + { + register int c1, c2; + struct token *t; + int tok_id; + + /* + * See if we are at white space or a comment. + */ + c1 = *next_char; + if (!IsWhSp(c1) && (c1 != '/' || next_char[1] != '*')) + return NULL; + + /* + * Fine the line number of the current character in the line number + * buffer, and correct it if we have encountered any #line directives. + */ + line = cs->line_buf[next_char - first_char] + cs->line_adj; + if (c1 == '\n') + --line; /* a new-line really belongs to the previous line */ + + tok_id = WhiteSpace; + for (;;) { + if (IsWhSp(c1)) { + /* + * The next character is a white space. If we are retaining the + * image of the white space in the token, copy the character to + * the string buffer. If we are in the midst of a preprocessor + * directive and find a new-line, indicate the end of the + * the directive. + */ + AdvChar(); + if (whsp_image != NoSpelling) + AppChar(tknize_sbuf, c1); + if (c1 == '\n') { + if (cs->dir_state == Within) + tok_id = PpDirEnd; + cs->dir_state = CanStart; + if (tok_id == PpDirEnd) + break; + } + } + else if (c1 == '/' && next_char[1] == '*') { + /* + * Start of comment. If we are retaining the image of comments, + * copy the characters into the string buffer. + */ + if (whsp_image == FullImage) { + AppChar(tknize_sbuf, '/'); + AppChar(tknize_sbuf, '*'); + } + AdvChar(); + AdvChar(); + + /* + * Look for the end of the comment. + */ + c1 = *next_char; + c2 = next_char[1]; + while (c1 != '*' || c2 != '/') { + if (c1 == EOF) + errfl1(fname, line, "eof encountered in comment"); + AdvChar(); + if (whsp_image == FullImage) + AppChar(tknize_sbuf, c1); + c1 = c2; + c2 = next_char[1]; + } + + /* + * Determine if we are retaining the image of a comment, replacing + * a comment by one space character, or ignoring comments. + */ + if (whsp_image == FullImage) { + AppChar(tknize_sbuf, '*'); + AppChar(tknize_sbuf, '/'); + } + else if (whsp_image == NoComment) + AppChar(tknize_sbuf, ' '); + AdvChar(); + AdvChar(); + } + else + break; /* end of white space */ + c1 = *next_char; + } + + /* + * If we are not retaining the image of white space, replace it all + * with one space character. + */ + if (whsp_image == NoSpelling) + AppChar(tknize_sbuf, ' '); + + t = new_token(tok_id, str_install(&tknize_sbuf), fname, line); + + /* + * Look ahead to see if a ## operator is next. + */ + if (*next_char == '#' && next_char[1] == '#') + if (tok_id == PpDirEnd) + errt1(t, "## expressions must not cross directive boundaries"); + else { + /* + * Discard white space before a ## operator. + */ + free_t(t); + return NULL; + } + return t; + } + +/* + * pp_number - Create a token for a preprocessing number (See ANSI C Standard + * for the syntax of such a number). + */ +static struct token *pp_number() + { + register int c; + + c = *next_char; + for (;;) { + if (c == 'e' || c == 'E') { + AppChar(tknize_sbuf, c); + AdvChar(); + c = *next_char; + if (c == '+' || c == '-') { + AppChar(tknize_sbuf, c); + AdvChar(); + c = *next_char; + } + } + else if (isdigit(c) || c == '.' || islower(c) || isupper(c) || c == '_') { + AppChar(tknize_sbuf, c); + AdvChar(); + c = *next_char; + } + else { + return new_token(PpNumber, str_install(&tknize_sbuf), fname, line); + } + } + } + +/* + * char_str - construct a token for a character constant or string literal. + */ +static struct token *char_str(delim, tok_id) +int delim; +int tok_id; + { + register int c; + + for (c = *next_char; c != EOF && c != '\n' && c != delim; c = *next_char) { + AppChar(tknize_sbuf, c); + if (c == '\\') { + c = next_char[1]; + if (c == EOF || c == '\n') + break; + else { + AppChar(tknize_sbuf, c); + AdvChar(); + } + } + AdvChar(); + } + if (c == EOF) + errfl1(fname, line, "End-of-file encountered within a literal"); + if (c == '\n') + errfl1(fname, line, "New-line encountered within a literal"); + AdvChar(); + return new_token(tok_id, str_install(&tknize_sbuf), fname, line); + } + +/* + * hdr_tok - create a token for an #include header. The delimiter may be + * > or ". + */ +static struct token *hdr_tok(delim, tok_id, cs) +int delim; +int tok_id; +struct char_src *cs; + { + register int c; + + line = cs->line_buf[next_char - first_char] + cs->line_adj; + AdvChar(); + + for (c = *next_char; c != delim; c = *next_char) { + if (c == EOF) + errfl1(fname, line, + "End-of-file encountered within a header name"); + if (c == '\n') + errfl1(fname, line, + "New-line encountered within a header name"); + AppChar(tknize_sbuf, c); + AdvChar(); + } + AdvChar(); + return new_token(tok_id, str_install(&tknize_sbuf), fname, line); + } + +/* + * tokenize - return the next token from the character source on the top + * of the source stack. + */ +struct token *tokenize() + { + struct char_src *cs; + struct token *t1, *t2; + register int c; + int tok_id; + + + cs = src_stack->u.cs; + + /* + * Check to see if the last call left a token from a look ahead. + */ + if (cs->tok_sav != NULL) { + t1 = cs->tok_sav; + cs->tok_sav = NULL; + return t1; + } + + if (*next_char == EOF) + return NULL; + + /* + * Find the current line number and file name for the character + * source and check for white space. + */ + line = cs->line_buf[next_char - first_char] + cs->line_adj; + fname = cs->fname; + if ((t1 = chck_wh_sp(cs)) != NULL) + return t1; + + c = *next_char; /* look at next character */ + AdvChar(); + + /* + * If the last thing we saw in this character source was white space + * containing a new-line, then we must look for the start of a + * preprocessing directive. + */ + if (cs->dir_state == CanStart) { + cs->dir_state = Reset; + if (c == '#' && *next_char != '#') { + /* + * Assume we are within a preprocessing directive and check + * for white space to discard. + */ + cs->dir_state = Within; + if ((t1 = chck_wh_sp(cs)) != NULL) + if (t1->tok_id == PpDirEnd) { + /* + * We found a new-line, this is a null preprocessor directive. + */ + cs->tok_sav = t1; + AppChar(tknize_sbuf, '#'); + return new_token(PpNull, str_install(&tknize_sbuf), fname, line); + } + else + free_t(t1); /* discard white space */ + c = *next_char; + if (islower(c) || isupper(c) || c == '_') { + /* + * Tokenize the identifier following the # + */ + t1 = tokenize(); + if ((tok_id = pp_tok_id(t1->image)) == Invalid) { + /* + * We have a stringizing operation, not a preprocessing + * directive. + */ + cs->dir_state = Reset; + cs->tok_sav = t1; + AppChar(tknize_sbuf, '#'); + return new_token('#', str_install(&tknize_sbuf), fname, line); + } + else { + t1->tok_id = tok_id; + if (tok_id == PpInclude) { + /* + * A header name has to be tokenized specially. Find + * it, then save the token. + */ + if ((t2 = chck_wh_sp(cs)) != NULL) + if (t2->tok_id == PpDirEnd) + errt1(t2, "file name missing from #include"); + else + free_t(t2); + c = *next_char; + if (c == '"') + cs->tok_sav = hdr_tok('"', StrLit, cs); + else if (c == '<') + cs->tok_sav = hdr_tok('>', PpHeader, cs); + } + /* + * Return the token indicating the kind of preprocessor + * directive we have started. + */ + return t1; + } + } + else + errfl1(fname, line, + "# must be followed by an identifier or keyword"); + } + } + + /* + * Check for literals containing wide characters. + */ + if (c == 'L') { + if (*next_char == '\'') { + AdvChar(); + t1 = char_str('\'', LCharConst); + if (t1->image[0] == '\0') + errt1(t1, "invalid character constant"); + return t1; + } + else if (*next_char == '"') { + AdvChar(); + return char_str('"', LStrLit); + } + } + + /* + * Check for identifier. + */ + if (islower(c) || isupper(c) || c == '_') { + AppChar(tknize_sbuf, c); + c = *next_char; + while (islower(c) || isupper(c) || isdigit(c) || c == '_') { + AppChar(tknize_sbuf, c); + AdvChar(); + c = *next_char; + } + return new_token(Identifier, str_install(&tknize_sbuf), fname, line); + } + + /* + * Check for number. + */ + if (isdigit(c)) { + AppChar(tknize_sbuf, c); + return pp_number(); + } + + /* + * Check for character constant. + */ + if (c == '\'') { + t1 = char_str(c, CharConst); + if (t1->image[0] == '\0') + errt1(t1, "invalid character constant"); + return t1; + } + + /* + * Check for string constant. + */ + if (c == '"') + return char_str(c, StrLit); + + /* + * Check for operators and punctuation. Anything that does not fit these + * categories is a single character token. + */ + AppChar(tknize_sbuf, c); + switch (c) { + case '.': + c = *next_char; + if (isdigit(c)) { + /* + * Number + */ + AppChar(tknize_sbuf, c); + AdvChar(); + return pp_number(); + } + else if (c == '.' && next_char[1] == '.') { + /* + * ... + */ + AdvChar(); + AdvChar(); + AppChar(tknize_sbuf, '.'); + AppChar(tknize_sbuf, '.'); + return new_token(Ellipsis, str_install(&tknize_sbuf), fname, line); + } + else + return new_token('.', str_install(&tknize_sbuf), fname, line); + + case '+': + c = *next_char; + if (c == '+') { + /* + * ++ + */ + AppChar(tknize_sbuf, '+'); + AdvChar(); + return new_token(Incr, str_install(&tknize_sbuf), fname, line); + } + else if (c == '=') { + /* + * += + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(PlusAsgn, str_install(&tknize_sbuf), fname, line); + } + else + return new_token('+', str_install(&tknize_sbuf), fname, line); + + case '-': + c = *next_char; + if (c == '>') { + /* + * -> + */ + AppChar(tknize_sbuf, '>'); + AdvChar(); + return new_token(Arrow, str_install(&tknize_sbuf), fname, line); + } + else if (c == '-') { + /* + * -- + */ + AppChar(tknize_sbuf, '-'); + AdvChar(); + return new_token(Decr, str_install(&tknize_sbuf), fname, line); + } + else if (c == '=') { + /* + * -= + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(MinusAsgn, str_install(&tknize_sbuf), fname, + line); + } + else + return new_token('-', str_install(&tknize_sbuf), fname, line); + + case '<': + c = *next_char; + if (c == '<') { + AppChar(tknize_sbuf, '<'); + AdvChar(); + if (*next_char == '=') { + /* + * <<= + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(LShftAsgn, str_install(&tknize_sbuf), fname, + line); + } + else + /* + * << + */ + return new_token(LShft, str_install(&tknize_sbuf), fname, line); + } + else if (c == '=') { + /* + * <= + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(Leq, str_install(&tknize_sbuf), fname, line); + } + else + return new_token('<', str_install(&tknize_sbuf), fname, line); + + case '>': + c = *next_char; + if (c == '>') { + AppChar(tknize_sbuf, '>'); + AdvChar(); + if (*next_char == '=') { + /* + * >>= + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(RShftAsgn, str_install(&tknize_sbuf), fname, + line); + } + else + /* + * >> + */ + return new_token(RShft, str_install(&tknize_sbuf), fname, line); + } + else if (c == '=') { + /* + * >= + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(Geq, str_install(&tknize_sbuf), fname, line); + } + else + return new_token('>', str_install(&tknize_sbuf), fname, line); + + case '=': + if (*next_char == '=') { + /* + * == + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(TokEqual, str_install(&tknize_sbuf), fname, line); + } + else + return new_token('=', str_install(&tknize_sbuf), fname, line); + + case '!': + if (*next_char == '=') { + /* + * != + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(Neq, str_install(&tknize_sbuf), fname, line); + } + else + return new_token('!', str_install(&tknize_sbuf), fname, line); + + case '&': + c = *next_char; + if (c == '&') { + /* + * && + */ + AppChar(tknize_sbuf, '&'); + AdvChar(); + return new_token(And, str_install(&tknize_sbuf), fname, line); + } + else if (c == '=') { + /* + * &= + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(AndAsgn, str_install(&tknize_sbuf), fname, line); + } + else + return new_token('&', str_install(&tknize_sbuf), fname, line); + + case '|': + c = *next_char; + if (c == '|') { + /* + * || + */ + AppChar(tknize_sbuf, '|'); + AdvChar(); + return new_token(Or, str_install(&tknize_sbuf), fname, line); + } + else if (c == '=') { + /* + * |= + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(OrAsgn, str_install(&tknize_sbuf), fname, line); + } + else + return new_token('|', str_install(&tknize_sbuf), fname, line); + + case '*': + if (*next_char == '=') { + /* + * *= + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(MultAsgn, str_install(&tknize_sbuf), fname, line); + } + else + return new_token('*', str_install(&tknize_sbuf), fname, line); + + case '/': + if (*next_char == '=') { + /* + * /= + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(DivAsgn, str_install(&tknize_sbuf), fname, line); + } + else + return new_token('/', str_install(&tknize_sbuf), fname, line); + + case '%': + if (*next_char == '=') { + /* + * &= + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(ModAsgn, str_install(&tknize_sbuf), fname, line); + } + else + return new_token('%', str_install(&tknize_sbuf), fname, line); + + case '^': + if (*next_char == '=') { + /* + * ^= + */ + AppChar(tknize_sbuf, '='); + AdvChar(); + return new_token(XorAsgn, str_install(&tknize_sbuf), fname, line); + } + else + return new_token('^', str_install(&tknize_sbuf), fname, line); + + case '#': + /* + * Token pasting or stringizing operator. + */ + if (*next_char == '#') { + /* + * ## + */ + AppChar(tknize_sbuf, '#'); + AdvChar(); + t1 = new_token(PpPaste, str_install(&tknize_sbuf), fname, line); + } + else + t1 = new_token('#', str_install(&tknize_sbuf), fname, line); + + /* + * The operand must be in the same preprocessing directive. + */ + if ((t2 = chck_wh_sp(cs)) != NULL) + if (t2->tok_id == PpDirEnd) + errt2(t2, t1->image, + " preprocessing expression must not cross directive boundary"); + else + free_t(t2); + return t1; + + default: + return new_token(c, str_install(&tknize_sbuf), fname, line); + } + } diff --git a/src/preproc/evaluate.c b/src/preproc/evaluate.c new file mode 100644 index 0000000..9c329f6 --- /dev/null +++ b/src/preproc/evaluate.c @@ -0,0 +1,561 @@ +/* + * This file contains functions to evaluate constant expressions for + * conditional inclusion. These functions are organized as a recursive + * decent parser based on the C grammar presented in the ANSI C Standard + * document. The function eval() is called from the outside. + */ + +#include "../preproc/preproc.h" +#include "../preproc/ptoken.h" + +/* + * Prototypes for static functions. + */ +static long primary (struct token **tp, struct token *trigger); +static long unary (struct token **tp, struct token *trigger); +static long multiplicative (struct token **tp, struct token *trigger); +static long additive (struct token **tp, struct token *trigger); +static long shift (struct token **tp, struct token *trigger); +static long relation (struct token **tp, struct token *trigger); +static long equality (struct token **tp, struct token *trigger); +static long and (struct token **tp, struct token *trigger); +static long excl_or (struct token **tp, struct token *trigger); +static long incl_or (struct token **tp, struct token *trigger); +static long log_and (struct token **tp, struct token *trigger); +static long log_or (struct token **tp, struct token *trigger); + +#include "../preproc/pproto.h" + +/* + * ::= + * defined + * defined '(' ')' + * + * + * '(' ')' + */ +static long primary(tp, trigger) +struct token **tp; +struct token *trigger; + { + struct token *t = NULL; + struct token *id = NULL; + long e1; + int i; + int is_hex_char; + char *s; + + switch ((*tp)->tok_id) { + case Identifier: + /* + * Check for "defined", it is the only reserved word in this expression + * evaluation (See ANSI C Standard). + */ + if (strcmp((*tp)->image, "defined") == 0) { + nxt_non_wh(&t); + if (t->tok_id == '(') { + nxt_non_wh(&id); + nxt_non_wh(&t); + if (t == NULL || t->tok_id != ')') + errt1(id, "')' missing in 'defined' expression"); + free_t(t); + } + else + id = t; + if (id->tok_id != Identifier) + errt1(id, "'defined' must be followed by an identifier"); + advance_tok(tp); + if (m_lookup(id) == NULL) + e1 = 0L; + else + e1 = 1L; + free_t(id); + } + else { + advance_tok(tp); + e1 = 0L; /* undefined: all macros have been expanded */ + } + return e1; + + case PpNumber: + s = (*tp)->image; + e1 = 0L; + if (*s == '0') { + ++s; + if ((*s == 'x') || (*s == 'X')) { + /* + * Hex constant + */ + ++s; + if (*s == '\0' || *s == 'u' || *s == 'U' || *s == 'l' || + *s == 'L') + errt2(*tp, "invalid hex constant in condition of #", + trigger->image); + while (*s != '\0' && *s != 'u' && *s != 'U' && *s != 'l' && + *s != 'L') { + e1 <<= 4; + if (*s >= '0' && *s <= '9') + e1 |= *s - '0'; + else + switch (*s) { + case 'a': case 'A': e1 |= 10; break; + case 'b': case 'B': e1 |= 11; break; + case 'c': case 'C': e1 |= 12; break; + case 'd': case 'D': e1 |= 13; break; + case 'e': case 'E': e1 |= 14; break; + case 'f': case 'F': e1 |= 15; break; + default: + errt2(*tp, "invalid hex constant in condition of #", + trigger->image); + } + ++s; + } + } + else { + /* + * Octal constant + */ + while (*s != '\0' && *s != 'u' && *s != 'U' && *s != 'l' && + *s != 'L') { + if (*s >= '0' && *s <= '7') + e1 = (e1 << 3) | (*s - '0'); + else + errt2(*tp, "invalid octal constant in condition of #", + trigger->image); + ++s; + } + } + } + else { + /* + * Decimal constant + */ + while (*s != '\0' && *s != 'u' && *s != 'U' && *s != 'l' && + *s != 'L') { + if (*s >= '0' && *s <= '9') + e1 = e1 * 10 + (*s - '0'); + else + errt2(*tp, "invalid decimal constant in condition of #", + trigger->image); + ++s; + } + } + advance_tok(tp); + /* + * Check integer suffix for validity + */ + if (*s == '\0') + return e1; + else if (*s == 'u' || *s == 'U') { + ++s; + if (*s == '\0') + return e1; + else if ((*s == 'l' || *s == 'L') && *++s == '\0') + return e1; + } + else if (*s == 'l' || *s == 'L') { + ++s; + if (*s == '\0') + return e1; + else if ((*s == 'u' || *s == 'U') && *++s == '\0') + return e1; + } + errt2(*tp, "invalid integer constant in condition of #", + trigger->image); + + case CharConst: + case LCharConst: + /* + * Wide characters are treated the same as characters. Only the + * first byte of a multi-byte character is used. + */ + s = (*tp)->image; + if (*s != '\\') + e1 = (long)*s; + else { + /* + * Escape sequence. + */ + e1 = 0L; + ++s; + if (*s >= '0' && *s <= '7') { + for (i = 1; i <= 3 && *s >= '0' && *s <= '7'; ++i, ++s) + e1 = (e1 << 3) | (*s - '0'); + if (e1 != (long)(unsigned char)e1) + errt1(*tp, "octal escape sequece larger than a character"); + e1 = (long)(char)e1; + } + else switch (*s) { + case '\'': e1 = (long) '\''; break; + case '"': e1 = (long) '"'; break; + case '?': e1 = (long) '?'; break; + case '\\': e1 = (long) '\\'; break; + case 'a': e1 = (long) Bell; break; + case 'b': e1 = (long) '\b'; break; + case 'f': e1 = (long) '\f'; break; + case 'n': e1 = (long) '\n'; break; + case 'r': e1 = (long) '\r'; break; + case 't': e1 = (long) '\t'; break; + case 'v': e1 = (long) '\v'; break; + + case 'x': + ++s; + is_hex_char = 1; + while (is_hex_char) { + if (*s >= '0' && *s <= '9') + e1 = (e1 << 4) | (*s - '0'); + else switch (*s) { + case 'a': case 'A': e1 = (e1 << 4) | 10; break; + case 'b': case 'B': e1 = (e1 << 4) | 11; break; + case 'c': case 'C': e1 = (e1 << 4) | 12; break; + case 'd': case 'D': e1 = (e1 << 4) | 13; break; + case 'e': case 'E': e1 = (e1 << 4) | 14; break; + case 'f': case 'F': e1 = (e1 << 4) | 15; break; + default: is_hex_char = 0; + } + if (is_hex_char) + ++s; + if (e1 != (long)(unsigned char)e1) + errt1(*tp,"hex escape sequece larger than a character"); + } + e1 = (long)(char)e1; + break; + + default: + e1 = (long) *s; + } + } + advance_tok(tp); + return e1; + + case '(': + advance_tok(tp); + e1 = conditional(tp, trigger); + if ((*tp)->tok_id != ')') + errt2(*tp, "expected ')' in conditional of #", trigger->image); + advance_tok(tp); + return e1; + + default: + errt2(*tp, "syntax error in condition of #", trigger->image); + } + /*NOTREACHED*/ + return 0; /* avoid gcc warning */ + } + +/* + * ::= | + * '+' | + * '-' | + * '~' | + * '!' + */ +static long unary(tp, trigger) +struct token **tp; +struct token *trigger; + { + switch ((*tp)->tok_id) { + case '+': + advance_tok(tp); + return unary(tp, trigger); + case '-': + advance_tok(tp); + return -unary(tp, trigger); + case '~': + advance_tok(tp); + return ~unary(tp, trigger); + case '!': + advance_tok(tp); + return !unary(tp, trigger); + default: + return primary(tp, trigger); + } + } + +/* + * ::= | + * '*' | + * '/' | + * '%' + */ +static long multiplicative(tp, trigger) +struct token **tp; +struct token *trigger; + { + long e1, e2; + int tok_id; + + e1 = unary(tp, trigger); + tok_id = (*tp)->tok_id; + while (tok_id == '*' || tok_id == '/' || tok_id == '%') { + advance_tok(tp); + e2 = unary(tp, trigger); + switch (tok_id) { + case '*': + e1 = (e1 * e2); + break; + case '/': + e1 = (e1 / e2); + break; + case '%': + e1 = (e1 % e2); + break; + } + tok_id = (*tp)->tok_id; + } + return e1; + } + +/* + * ::= | + * '+' | + * '-' + */ +static long additive(tp, trigger) +struct token **tp; +struct token *trigger; + { + long e1, e2; + int tok_id; + + e1 = multiplicative(tp, trigger); + tok_id = (*tp)->tok_id; + while (tok_id == '+' || tok_id == '-') { + advance_tok(tp); + e2 = multiplicative(tp, trigger); + if (tok_id == '+') + e1 = (e1 + e2); + else + e1 = (e1 - e2); + tok_id = (*tp)->tok_id; + } + return e1; + } + +/* + * ::= | + * '<<' | + * '>>' + */ +static long shift(tp, trigger) +struct token **tp; +struct token *trigger; + { + long e1, e2; + int tok_id; + + e1 = additive(tp, trigger); + tok_id = (*tp)->tok_id; + while (tok_id == LShft || tok_id == RShft) { + advance_tok(tp); + e2 = additive(tp, trigger); + if (tok_id == LShft) + e1 = (e1 << e2); + else + e1 = (e1 >> e2); + tok_id = (*tp)->tok_id; + } + return e1; + } + +/* + * ::= | + * '<' | + * '<=' | + * '>' | + * '>=' + */ +static long relation(tp, trigger) +struct token **tp; +struct token *trigger; + { + long e1, e2; + int tok_id; + + e1 = shift(tp, trigger); + tok_id = (*tp)->tok_id; + while (tok_id == '<' || tok_id == Leq || tok_id == '>' || tok_id == Geq) { + advance_tok(tp); + e2 = shift(tp, trigger); + switch (tok_id) { + case '<': + e1 = (e1 < e2); + break; + case Leq: + e1 = (e1 <= e2); + break; + case '>': + e1 = (e1 > e2); + break; + case Geq: + e1 = (e1 >= e2); + break; + } + tok_id = (*tp)->tok_id; + } + return e1; + } + +/* + * ::= | + * '==' | + * '!=' + */ +static long equality(tp, trigger) +struct token **tp; +struct token *trigger; + { + long e1, e2; + int tok_id; + + e1 = relation(tp, trigger); + tok_id = (*tp)->tok_id; + while (tok_id == TokEqual || tok_id == Neq) { + advance_tok(tp); + e2 = relation(tp, trigger); + if (tok_id == TokEqual) + e1 = (e1 == e2); + else + e1 = (e1 != e2); + tok_id = (*tp)->tok_id; + } + return e1; + } + +/* + * ::= | + * '&' + */ +static long and(tp, trigger) +struct token **tp; +struct token *trigger; + { + long e1, e2; + + e1 = equality(tp, trigger); + while ((*tp)->tok_id == '&') { + advance_tok(tp); + e2 = equality(tp, trigger); + e1 = (e1 & e2); + } + return e1; + } + +/* + * ::= | + * '^' + */ +static long excl_or(tp, trigger) +struct token **tp; +struct token *trigger; + { + long e1, e2; + + e1 = and(tp, trigger); + while ((*tp)->tok_id == '^') { + advance_tok(tp); + e2 = and(tp, trigger); + e1 = (e1 ^ e2); + } + return e1; + } + +/* + * ::= | + * '|' + */ +static long incl_or(tp, trigger) +struct token **tp; +struct token *trigger; + { + long e1, e2; + + e1 = excl_or(tp, trigger); + while ((*tp)->tok_id == '|') { + advance_tok(tp); + e2 = excl_or(tp, trigger); + e1 = (e1 | e2); + } + return e1; + } + +/* + * ::= | + * '&&' + */ +static long log_and(tp, trigger) +struct token **tp; +struct token *trigger; + { + long e1, e2; + + e1 = incl_or(tp, trigger); + while ((*tp)->tok_id == And) { + advance_tok(tp); + e2 = incl_or(tp, trigger); + e1 = (e1 && e2); + } + return e1; + } + +/* + * ::= | + * '||' + */ +static long log_or(tp, trigger) +struct token **tp; +struct token *trigger; + { + long e1, e2; + + e1 = log_and(tp, trigger); + while ((*tp)->tok_id == Or) { + advance_tok(tp); + e2 = log_and(tp, trigger); + e1 = (e1 || e2); + } + return e1; + } + +/* + * ::= | + * '?' ':' + */ +long conditional(tp, trigger) +struct token **tp; +struct token *trigger; + { + long e1, e2, e3; + + e1 = log_or(tp, trigger); + if ((*tp)->tok_id == '?') { + advance_tok(tp); + e2 = conditional(tp, trigger); + if ((*tp)->tok_id != ':') + errt2(*tp, "expected ':' in conditional of #", trigger->image); + advance_tok(tp); + e3 = conditional(tp, trigger); + return e1 ? e2 : e3; + } + else + return e1; + } + +/* + * eval - get the tokens for a conditional and evaluate it to 0 or 1. + * trigger is the preprocessing directive that triggered the evaluation; + * it is used for error messages. + */ +int eval(trigger) +struct token *trigger; + { + struct token *t = NULL; + int result; + + advance_tok(&t); + result = (conditional(&t, trigger) != 0L); + if (t->tok_id != PpDirEnd) + errt2(t, "expected end of condition of #", trigger->image); + free_t(t); + return result; + } diff --git a/src/preproc/files.c b/src/preproc/files.c new file mode 100644 index 0000000..07abf60 --- /dev/null +++ b/src/preproc/files.c @@ -0,0 +1,257 @@ +/* + * This file contains routines for setting up characters sources from + * files. It contains code to handle the search for include files. + */ +#include "../preproc/preproc.h" +#include "../preproc/pproto.h" + +#if CYGWIN + #include + #include + #include +#endif /* CYGWIN */ + +#define IsRelPath(fname) (fname[0] != '/') + +static void file_src (char *fname, FILE *f); + +static char **incl_search; /* standard locations to search for header files */ + +/* + * file_src - set up the structures for a characters source from a file, + * putting the source on the top of the stack. + */ +static void file_src(fname, f) +char *fname; +FILE *f; + { + union src_ref ref; + + #if CYGWIN + char posix_path[ _POSIX_PATH_MAX + 1 ]; + cygwin_conv_to_posix_path( fname, posix_path ); + fname = strdup( posix_path ); + #endif /* CYGWIN */ + + ref.cs = new_cs(fname, f, CBufSize); + push_src(CharSrc, &ref); + next_char = NULL; + fill_cbuf(); + } + +/* + * source - Open the file named fname or use stdin if fname is "-". fname + * is the first file from which to read input (that is, the outermost file). + */ +void source(fname) +char *fname; + { + FILE *f; + + if (strcmp(fname, "-") == 0) + file_src("", stdin); + else { + if ((f = fopen(fname, "r")) == NULL) + err2("cannot open ", fname); + file_src(fname, f); + } + } + +/* + * include - open the file named fname and make it the current input file. + */ +void include(trigger, fname, system) +struct token *trigger; +char *fname; +int system; + { + struct str_buf *sbuf; + char *s; + char *path; + char *end_prfx; + struct src *sp; + struct char_src *cs; + char **prefix; + FILE *f; + + /* + * See if this is an absolute path name. + */ + if (IsRelPath(fname)) { + sbuf = get_sbuf(); + f = NULL; + if (!system) { + /* + * This is not a system include file, so search the locations + * of the "ancestor files". + */ + sp = src_stack; + while (f == NULL && sp != NULL) { + if (sp->flag == CharSrc) { + cs = sp->u.cs; + if (cs->f != NULL) { + /* + * This character source is a file. + */ + end_prfx = NULL; + for (s = cs->fname; *s != '\0'; ++s) + if (*s == '/') + end_prfx = s; + if (end_prfx != NULL) + for (s = cs->fname; s <= end_prfx; ++s) + AppChar(*sbuf, *s); + for (s = fname; *s != '\0'; ++s) + AppChar(*sbuf, *s); + path = str_install(sbuf); + f = fopen(path, "r"); + } + } + sp = sp->next; + } + } + /* + * Search in the locations for the system include files. + */ + prefix = incl_search; + while (f == NULL && *prefix != NULL) { + for (s = *prefix; *s != '\0'; ++s) + AppChar(*sbuf, *s); + if (s > *prefix && s[-1] != '/') + AppChar(*sbuf, '/'); + for (s = fname; *s != '\0'; ++s) + AppChar(*sbuf, *s); + path = str_install(sbuf); + f = fopen(path, "r"); + ++prefix; + } + rel_sbuf(sbuf); + } + else { /* The path is absolute. */ + path = fname; + f = fopen(path, "r"); + } + + if (f == NULL) + errt2(trigger, "cannot open include file ", fname); + file_src(path, f); + } + +/* + * init_files - Initialize this module, setting up the search path for + * system header files. + */ +void init_files(opt_lst, opt_args) +char *opt_lst; +char **opt_args; + { + int n_paths = 0; + int i, j; + char *s, *s1; + + /* + * Determine the number of standard locations to search for + * header files and provide any declarations needed for the code + * that establishes these search locations. + */ + + #if CYGWIN + char *incl_var; + static char *sysdir = "/usr/include"; + static char *windir = "/usr/include/w32api"; + n_paths = 2; + + incl_var = getenv("C_INCLUDE_PATH"); + if (incl_var != NULL) { + /* + * Add one entry for evry non-empty, colon-separated string in incl_var. + */ + char *dir_start, *dir_end; + + dir_start = incl_var; + while( ( dir_end = strchr( dir_start, ':' ) ) != NULL ) { + if (dir_end > dir_start) ++n_paths; + dir_start = dir_end + 1; + } + if ( *dir_start != '\0' ) + ++n_paths; /* One path after the final ':' */ + } + #else /* CYGWIN */ + static char *sysdir = "/usr/include/"; + n_paths = 1; + #endif /* CYGWIN */ + + /* + * Count the number of -I options to the preprocessor. + */ + for (i = 0; opt_lst[i] != '\0'; ++i) + if (opt_lst[i] == 'I') + ++n_paths; + + /* + * Set up the array of standard locations to search for header files. + */ + incl_search = alloc((n_paths + 1) * sizeof(char *)); + j = 0; + + /* + * Get the locations from the -I options to the preprocessor. + */ + for (i = 0; opt_lst[i] != '\0'; ++i) + if (opt_lst[i] == 'I') { + s = opt_args[i]; + s1 = alloc(strlen(s) + 1); + strcpy(s1, s); + + #if CYGWIN + /* + * Run s1 through cygwin_conv_to_posix_path; if the posix path + * differs from s1, reset s1 to a copy of the posix path. + */ + { + char posix_path[ _POSIX_PATH_MAX ]; + cygwin_conv_to_posix_path( s1, posix_path ); + if (strcmp( s1, posix_path ) != 0) { + free( s1 ); + s1 = salloc( posix_path ); + } + } + #endif /* CYGWIN */ + + incl_search[j++] = s1; + } + + /* + * Establish the standard locations to search after the -I options + * on the preprocessor. + */ + #if CYGWIN + if (incl_var != NULL) { + /* + * The C_INCLUDE_PATH components are carved out of a copy of incl_var. + * The colons after non-empty directory names are replaced by null + * chars, and the pointers to the start of these names are stored + * in inc_search. + */ + char *dir_start, *dir_end; + + dir_start = salloc( incl_var ); + while( ( dir_end = strchr( dir_start, ':' ) ) != NULL ) { + if (dir_end > dir_start) { + incl_search[j++] = dir_start; + *dir_end = '\0'; + } + dir_start = dir_end + 1; + } + if ( *dir_start != '\0' ) + incl_search[j++] = dir_start; + } + + /* Finally, add the system dir(s) */ + incl_search[j++] = sysdir; + incl_search[j++] = windir; + #else + incl_search[n_paths - 1] = sysdir; + #endif /* CYGWIN */ + + incl_search[n_paths] = NULL; + } diff --git a/src/preproc/gettok.c b/src/preproc/gettok.c new file mode 100644 index 0000000..87fe5f0 --- /dev/null +++ b/src/preproc/gettok.c @@ -0,0 +1,252 @@ +/* + * This files contains routines for getting the "next" token. + */ +#include "../preproc/preproc.h" +#include "../preproc/ptoken.h" +#include "../preproc/pproto.h" + +/* + * next_tok - get the next raw token. No macros are expanded here (although + * the tokens themselves may be the result of a macro expansion initiated + * at a "higher" level). Only #line directives are processed here. + */ +struct token *next_tok() + { + struct token *t, *t1; + struct tok_lst *tlst; + struct char_src *cs; + struct str_buf *sbuf; + char *s; + char *fname; + int n; + + if (src_stack->flag == DummySrc) + return NULL; /* source stack is empty - end of input */ + + /* + * See if a directive pushed back any tokens. + */ + if (src_stack->ntoks > 0) + return src_stack->toks[--src_stack->ntoks]; + + switch (src_stack->flag) { + case CharSrc: + /* + * Tokens from a raw character "stream". + */ + t = tokenize(); + if (t != NULL && src_stack->u.cs->f != NULL) + t->flag |= LineChk; + if (t != NULL && t->tok_id == PpLine) { + /* + * #line directives must be processed here so they are not + * put in macros. + */ + cs = src_stack->u.cs; + t1 = NULL; + + /* + * Get the line number from the directive. + */ + advance_tok(&t1); + if (t1->tok_id != PpNumber) + errt1(t1, "#line requires an integer argument"); + n = 0; + for (s = t1->image; *s != '\0'; ++s) { + if (*s >= '0' && *s <= '9') + n = 10 * n + (*s - '0'); + else + errt1(t1, "#line requires an integer argument"); + } + + /* + * Get the file name, if there is one, from the directive. + */ + advance_tok(&t1); + fname = NULL; + if (t1->tok_id == StrLit) { + sbuf = get_sbuf(); + for (s = t1->image; *s != '\0'; ++s) { + if (s[0] == '\\' && (s[1] == '\\' || s[1] == '"')) + ++s; + AppChar(*sbuf, *s); + } + fname = str_install(sbuf); + rel_sbuf(sbuf); + advance_tok(&t1); + } + if (t1->tok_id != PpDirEnd) + errt1(t1, "syntax error in #line"); + + /* + * Note the effect of the line directive in the character + * source. Line number changes are handled as a relative + * adjustments to the line numbers of following lines. + */ + if (fname != NULL) + cs->fname = fname; + cs->line_adj = n - cs->line_buf[next_char - first_char + 1]; + if (*next_char == '\n') + ++cs->line_adj; /* the next lines contains no characters */ + + t = next_tok(); /* the caller does not see #line directives */ + } + break; + + case MacExpand: + /* + * Tokens from macro expansion. + */ + t = mac_tok(); + break; + + case TokLst: + /* + * Tokens from a macro argument. + */ + tlst = src_stack->u.tlst; + if (tlst == NULL) + t = NULL; + else { + t = copy_t(tlst->t); + src_stack->u.tlst = tlst->next; + } + break; + + case PasteLsts: + /* + * Tokens from token Pasting. + */ + return paste(); + } + + if (t == NULL) { + /* + * We have exhausted this entry on the source stack without finding + * a token to return. + */ + pop_src(); + return next_tok(); + } + else + return t; + } + +/* + * Get the next raw non-white space token, freeing token that the argument + * used to point to. + */ +void nxt_non_wh(tp) +struct token **tp; + { + register struct token *t; + + t = next_tok(); + while (t != NULL && t->tok_id == WhiteSpace) { + free_t(t); + t = next_tok(); + } + free_t(*tp); + *tp = t; + } + +/* + * advance_tok - skip past white space after expanding macros and + * executing preprocessor directives. This routine may only be + * called from within a preprocessor directive because it assumes + * it will not see EOF (the input routines insure that a terminating + * new-line, and thus, for a directive, the PpDirEnd token, will be + * seen immediately before EOF). + */ +void advance_tok(tp) +struct token **tp; + { + struct token *t; + + t = interp_dir(); + while (t->tok_id == WhiteSpace) { + free_t(t); + t = interp_dir(); + } + free_t(*tp); + *tp = t; + } + +/* + * merge_whsp - merge a sequence of white space tokens into one token, + * returning it along with the next token. Whether these are raw or + * processed tokens depends on the token source function, t_src. + */ +void merge_whsp(whsp, next_t, t_src) +struct token **whsp; +struct token **next_t; +struct token *(*t_src)(void); + { + struct token *t1; + struct str_buf *sbuf; + int line = -1; + char *fname = ""; + char *s; + + free_t(*whsp); + t1 = (*t_src)(); + if (t1 == NULL || t1->tok_id != WhiteSpace) + *whsp = NULL; /* no white space here */ + else { + *whsp = t1; + t1 = (*t_src)(); + if (t1 != NULL && t1->tok_id == WhiteSpace) { + if (whsp_image == NoSpelling) { + /* + * We don't care what the white space looks like, so + * discard the rest of it. + */ + while (t1 != NULL && t1->tok_id == WhiteSpace) { + free_t(t1); + t1 = (*t_src)(); + } + } + else { + /* + * Must actually merge white space. Put it all white space + * in a string buffer and use that as the image of the merged + * token. The line number and file name of the new token + * is that of the last token whose line number and file + * name is important for generating #line directives in + * the output. + */ + sbuf = get_sbuf(); + if ((*whsp)->flag & LineChk) { + line = (*whsp)->line; + fname = (*whsp)->fname; + } + for (s = (*whsp)->image; *s != '\0'; ++s) { + AppChar(*sbuf, *s); + if (*s == '\n' && line != -1) + ++line; + } + while (t1 != NULL && t1->tok_id == WhiteSpace) { + if (t1->flag & LineChk) { + line = t1->line; + fname = t1->fname; + } + for (s = t1->image; *s != '\0'; ++s) { + AppChar(*sbuf, *s); + if (*s == '\n' && line != -1) + ++line; + } + free_t(t1); + t1 = (*t_src)(); + } + (*whsp)->image = str_install(sbuf); + rel_sbuf(sbuf); + if (t1 != NULL && !(t1->flag & LineChk) && line != -1) { + t1->flag |= LineChk; + t1->line = line; + t1->fname = fname; + } + } + } + } + *next_t = t1; + } diff --git a/src/preproc/macro.c b/src/preproc/macro.c new file mode 100644 index 0000000..d40ac36 --- /dev/null +++ b/src/preproc/macro.c @@ -0,0 +1,659 @@ +/* + * This file contains various functions for dealing with macros. + */ +#include "../preproc/preproc.h" +#include "../preproc/ptoken.h" +#include "../preproc/pproto.h" + +/* + * Prototypes for static functions. + */ +static struct macro **m_find (char *mname); +static int eq_id_lst (struct id_lst *lst1, struct id_lst *lst2); +static int eq_tok_lst (struct tok_lst *lst1, struct tok_lst *lst2); +static int parm_indx (char *id, struct macro *m); +static void cpy_str (char *ldelim, char *image, + char *rdelim, struct str_buf *sbuf); +static struct token *stringize (struct token *trigger, + struct mac_expand *me); +static struct paste_lsts *paste_parse (struct token *t, + struct mac_expand *me); +static int *cpy_image (struct token *t, int *s); + +#define MacTblSz 149 +#define MHash(x) (((unsigned int)(unsigned long)(x)) % MacTblSz) + +static struct macro *m_table[MacTblSz]; /* hash table of macros */ + +int max_recurse; + +/* + * Some string to put in the string table: + */ +static char *line_mac = "__LINE__"; +static char *file_mac = "__FILE__"; +static char *date_mac = "__DATE__"; +static char *time_mac = "__TIME__"; +static char *rcrs_mac = "__RCRS__"; +static char *defined = "defined"; + +/* + * m_find - return return location of pointer to where macro belongs in + * macro table. If the macro is not in the table, the pointer at the + * location is NULL. + */ +static struct macro **m_find(mname) +char *mname; + { + struct macro **mpp; + + for (mpp = &m_table[MHash(mname)]; *mpp != NULL && (*mpp)->mname != mname; + mpp = &(*mpp)->next) + ; + return mpp; + } + +/* + * eq_id_lst - check to see if two identifier lists contain the same identifiers + * in the same order. + */ +static int eq_id_lst(lst1, lst2) +struct id_lst *lst1; +struct id_lst *lst2; + { + if (lst1 == lst2) + return 1; + if (lst1 == NULL || lst2 == NULL) + return 0; + if (lst1->id != lst2->id) + return 0; + return eq_id_lst(lst1->next, lst2->next); + } + +/* + * eq_tok_lst - check to see if 2 token lists contain the same tokens + * in the same order. All white space tokens are considered equal. + */ +static int eq_tok_lst(lst1, lst2) +struct tok_lst *lst1; +struct tok_lst *lst2; + { + if (lst1 == lst2) + return 1; + if (lst1 == NULL || lst2 == NULL) + return 0; + if (lst1->t->tok_id != lst2->t->tok_id) + return 0; + if (lst1->t->tok_id != WhiteSpace && lst1->t->tok_id != PpDirEnd && + lst1->t->image != lst2->t->image) + return 0; + return eq_tok_lst(lst1->next, lst2->next); + } + +/* + * init_macro - initialize this module, setting up standard macros. + */ +void init_macro() + { + int i; + struct macro **mpp; + struct token *t; + time_t tv; + char *s, *tval; + static char *time_buf; + static char *date_buf; + static short first_time = 1; + + if (first_time) { + first_time = 0; + /* + * Add names of standard macros to sting table. + */ + line_mac = spec_str(line_mac); + file_mac = spec_str(file_mac); + date_mac = spec_str(date_mac); + time_mac = spec_str(time_mac); + rcrs_mac = spec_str(rcrs_mac); + defined = spec_str(defined); + } + else { + /* + * Free macro definitions from the file processed. + */ + for (i = 0; i < MacTblSz; ++i) + free_m_lst(m_table[i]); + } + + for (i = 0; i < MacTblSz; ++i) + m_table[i] = NULL; + + /* + * __LINE__ and __FILE__ are macros that require special processing + * when they are processed. Indicate that. + */ + mpp = m_find(line_mac); + *mpp = new_macro(line_mac, SpecMac, 0, NULL, NULL); + + mpp = m_find(file_mac); + *mpp = new_macro(file_mac, SpecMac, 0, NULL, NULL); + + /* + * __TIME__ and __DATE__ must be initialized to the current time and + * date. + */ + time(&tv); + tval = ctime(&tv); + date_buf = alloc(12); + time_buf = alloc(9); + s = date_buf; + for (i = 4; i <= 10; ++i) + *s++ = tval[i]; + for (i = 20; i <= 23; ++i) + *s++ = tval[i]; + *s = '\0'; + s = time_buf; + for (i = 11; i <= 18; ++i) + *s++ = tval[i]; + *s = '\0'; + date_buf = spec_str(date_buf); + time_buf = spec_str(time_buf); + + t = new_token(StrLit, date_buf, "", 0); + mpp = m_find(date_mac); + *mpp = new_macro(date_mac, FixedMac, 0, NULL, new_t_lst(t)); + + t = new_token(StrLit, time_buf, "", 0); + mpp = m_find(time_mac); + *mpp = new_macro(time_mac, FixedMac, 0, NULL, new_t_lst(t)); + + /* + * __RCRS__ is a special macro to indicate the allowance of + * recursive macros. It is not ANSI-standard. Initialize it + * to "1". + */ + mpp = m_find(rcrs_mac); + *mpp = new_macro(rcrs_mac, NoArgs, 0, NULL, new_t_lst(copy_t(one_tok))); + max_recurse = 1; + } + +/* + * m_install - install a macro. + */ +void m_install(mname, category, multi_line, prmlst, body) +struct token *mname; /* name of macro */ +int multi_line; /* flag indicating if this is a multi-line macro */ +int category; /* # parms, or NoArgs if it is object-like macro */ +struct id_lst *prmlst; /* parameter list */ +struct tok_lst *body; /* replacement list */ + { + struct macro **mpp; + char *s; + + if (mname->image == defined) + errt1(mname, "'defined' may not be the subject of #define"); + + /* + * The special macro __RCRS__ may only be defined as a single integer + * token and must be an object-like macro. + */ + if (mname->image == rcrs_mac) { + if (body == NULL || body->t->tok_id != PpNumber || body->next != NULL) + errt1(mname, "__RCRS__ must be a decimal integer"); + if (category != NoArgs) + errt1(mname, "__RSCS__ may have no arguments"); + max_recurse = 0; + for (s = body->t->image; *s != '\0'; ++s) { + if (*s >= '0' && *s <= '9') + max_recurse = max_recurse * 10 + (*s - '0'); + else + errt1(mname, "__RCRS__ must be a decimal integer"); + } + } + + mpp = m_find(mname->image); + if (*mpp == NULL) + *mpp = new_macro(mname->image, category, multi_line, prmlst, body); + else { + /* + * The macro is already defined. Make sure it is identical (up to + * white space) to this definition. + */ + if (!((*mpp)->category == category && eq_id_lst((*mpp)->prmlst, prmlst) && + eq_tok_lst((*mpp)->body, body))) + errt2(mname, "invalid redefinition of macro ", mname->image); + free_id_lst(prmlst); + free_t_lst(body); + } + } + +/* + * m_delete - delete a macro. + */ +void m_delete(mname) +struct token *mname; + { + struct macro **mpp, *mp; + + if (mname->image == defined) + errt1(mname, "'defined' may not be the subject of #undef"); + + /* + * Undefining __RCRS__ allows unlimited macro recursion (non-ANSI + * standard feature. + */ + if (mname->image == rcrs_mac) + max_recurse = -1; + + /* + * Make sure undefining this macro is allowed, and free storage + * associate with it. + */ + mpp = m_find(mname->image); + if (*mpp != NULL) { + mp = *mpp; + if (mp->category == FixedMac || mp->category == SpecMac) + errt2(mname, mname->image, " may not be the subject of #undef"); + *mpp = mp->next; + free_m(mp); + } + } + +/* + * m_lookup - lookup a macro name. Return pointer to macro, if it is defined; + * return NULL, if it is not. This routine sets the definition for macros + * whose definitions various from place to place. + */ +struct macro *m_lookup(id) +struct token *id; + { + struct macro *m; + static char buf[20]; + + m = *m_find(id->image); + if (m != NULL && m->category == SpecMac) + if (m->mname == line_mac) { /* __LINE___ */ + sprintf(buf, "%d", id->line); + m->body = new_t_lst(new_token(PpNumber, buf, id->fname, + id->line)); + } + else if (m->mname == file_mac) /* __FILE__ */ + m->body = new_t_lst(new_token(StrLit, id->fname, id->fname, + id->line)); + return m; + } + +/* + * parm_indx - see if a name is a paramter to the given macro. + */ +static int parm_indx(id, m) +char *id; +struct macro *m; + { + struct id_lst *idlst; + int i; + + for (i = 0, idlst = m->prmlst; i < m->category; i++, idlst = idlst->next) + if (id == idlst->id) + return i; + return -1; + } + +/* + * cpy_str - copy a string into a string buffer, adding delimiters. + */ +static void cpy_str(ldelim, image, rdelim, sbuf) +char *ldelim; +char *image; +char *rdelim; +struct str_buf *sbuf; + { + register char *s; + + for (s = ldelim; *s != '\0'; ++s) + AppChar(*sbuf, *s); + + for (s = image; *s != '\0'; ++s) { + if (*s == '\\' || *s == '"') + AppChar(*sbuf, '\\'); + AppChar(*sbuf, *s); + } + + for (s = rdelim; *s != '\0'; ++s) + AppChar(*sbuf, *s); + } + +/* + * stringize - create a stringized version of a token. + */ +static struct token *stringize(trigger, me) +struct token *trigger; +struct mac_expand *me; + { + register struct token *t; + struct tok_lst *arg; + struct str_buf *sbuf; + char *s; + int indx; + + /* + * Get the next token from the macro body. It must be a macro parameter; + * retrieve the raw tokens for the corresponding argument. + */ + if (me->rest_bdy == NULL) + errt1(trigger, "the # operator must have an argument"); + t = me->rest_bdy->t; + me->rest_bdy = me->rest_bdy->next; + if (t->tok_id == Identifier) + indx = parm_indx(t->image, me->m); + else + indx = -1; + if (indx == -1) + errt1(t, "the # operator may only be applied to a macro argument"); + arg = me->args[indx]; + + /* + * Copy the images for the argument tokens into a string buffer. Note + * that the images of string and character literals lack quotes; these + * must be escaped in the stringized value. + */ + sbuf = get_sbuf(); + while (arg != NULL) { + t = arg->t; + if (t->tok_id == WhiteSpace) + AppChar(*sbuf, ' '); + else if (t->tok_id == StrLit) + cpy_str("\\\"", t->image, "\\\"", sbuf); + else if (t->tok_id == LStrLit) + cpy_str("L\\\"", t->image, "\\\"", sbuf); + else if (t->tok_id == CharConst) + cpy_str("'", t->image, "'", sbuf); + else if (t->tok_id == LCharConst) + cpy_str("L'", t->image, "'", sbuf); + else + for (s = t->image; *s != '\0'; ++s) + AppChar(*sbuf, *s); + arg = arg->next; + } + + /* + * Created the token for the stringized argument. + */ + t = new_token(StrLit, str_install(sbuf), trigger->fname, trigger->line); + t->flag |= trigger->flag & LineChk; + rel_sbuf(sbuf); + return t; + } + +/* + * paste_parse - parse an expression involving token pasting operators (and + * stringizing operators). Return a list of token lists. Each token list + * is from a token pasting operand, with operands that are macro parameters + * replaced by their corresponding argument (this is why a list of tokens + * is needed for each operand). Any needed stringizing is done as the list + * is created. + */ +static struct paste_lsts *paste_parse(t, me) +struct token *t; +struct mac_expand *me; + { + struct token *t1; + struct token *trigger = NULL; + struct tok_lst *lst; + struct paste_lsts *plst; + int indx; + + if (me->rest_bdy == NULL || me->rest_bdy->t->tok_id != PpPaste) + plst = NULL; /* we have reached the end of the pasting expression */ + else { + /* + * The next token is a pasting operator. Copy it an move on to the + * operand. + */ + trigger = copy_t(me->rest_bdy->t); + me->rest_bdy = me->rest_bdy->next; + if (me->rest_bdy == NULL) + errt1(t, "the ## operator must not appear at the end of a macro"); + t1 = me->rest_bdy->t; + me->rest_bdy = me->rest_bdy->next; + + /* + * See if the operand is a stringizing operation. + */ + if (t1->tok_id == '#') + t1 = stringize(t1, me); + else + t1 = copy_t(t1); + plst = paste_parse(t1, me); /* get any further token pasting */ + } + + /* + * If the operand is a macro parameter, replace it by the corresponding + * argument, otherwise make the operand into a 1-element token list. + */ + indx = -1; + if (t->tok_id == Identifier) + indx = parm_indx(t->image, me->m); + if (indx == -1) + lst = new_t_lst(t); + else { + lst = me->args[indx]; + free_t(t); + } + + /* + * Ignore emtpy arguments when constructing the pasting list. + */ + if (lst == NULL) + return plst; + else + return new_plsts(trigger, lst, plst); + } + +/* + * cpy_image - copy the image of a token into a character buffer adding + * delimiters if it is a string or character literal. + */ +static int *cpy_image(t, s) +struct token *t; +int *s; /* the string buffer can contain EOF */ + { + register char *s1; + + switch (t->tok_id) { + case StrLit: + *s++ = '"'; + break; + case LStrLit: + *s++ = 'L'; + *s++ = '"'; + break; + case CharConst: + *s++ = '\''; + break; + case LCharConst: + *s++ = 'L'; + *s++ = '\''; + break; + } + + s1 = t->image; + while (*s1 != '\0') + *s++ = *s1++; + + switch (t->tok_id) { + case StrLit: + case LStrLit: + *s++ = '"'; + break; + case CharConst: + case LCharConst: + *s++ = '\''; + break; + } + + return s; + } + +/* + * paste - return the next token from a source which pastes tokens. The + * source may represent a series of token pasting operators. + */ +struct token *paste() + { + struct token *t; + struct token *t1; + struct token *trigger; + struct paste_lsts *plst; + union src_ref ref; + int i; + int *s; + + plst = src_stack->u.plsts; + + /* + * If the next token of the current list is not the one to be pasted, + * just return it. + */ + t = copy_t(plst->tlst->t); + plst->tlst = plst->tlst->next; + if (plst->tlst != NULL) + return t; + + /* + * We have the last token from the current list. If there is another + * list, this token must be pasted to the first token of that list. + * Make the next list the current one and get its first token. + */ + trigger = plst->trigger; + plst = plst->next; + free_plsts(src_stack->u.plsts); + src_stack->u.plsts = plst; + if (plst == NULL) { + pop_src(); + return t; + } + t1 = next_tok(); + + /* + * Paste tokens by creating a character source with the images of the + * two tokens concatenated. + */ + ref.cs = new_cs(trigger->fname, NULL, + (int)strlen(t->image) + (int)strlen(t1->image) + 7); + push_src(CharSrc, &ref); + s = cpy_image(t, ref.cs->char_buf); + s = cpy_image(t1, s); + *s = EOF; + + /* + * Treat all characters of the new source as if they come from the + * location of the token pasting. + */ + for (i = 0; i < (s - ref.cs->char_buf + 1); ++i) + *(ref.cs->line_buf) = trigger->line; + ref.cs->last_char = s; + ref.cs->dir_state = Reset; + first_char = ref.cs->char_buf; + next_char = first_char; + last_char = ref.cs->last_char; + + return next_tok(); /* first token from pasted images */ + } + +/* + * mac_tok - return the next token from a source which is a macro. + */ +struct token *mac_tok() + { + struct mac_expand *me; + register struct token *t, *t1; + struct paste_lsts *plst; + union src_ref ref; + int line_check; + int indx; + int line; + char *fname; + + me = src_stack->u.me; /* macro, current position, and arguments */ + + /* + * Get the next token from the macro body. + */ + if (me->rest_bdy == NULL) + return NULL; + t = me->rest_bdy->t; + me->rest_bdy = me->rest_bdy->next; + + /* + * If this token is a stringizing operator, try stringizing the next + * token. + */ + if (t->tok_id == '#') + t = stringize(t, me); + else + t = copy_t(t); + + if (me->rest_bdy != NULL && me->rest_bdy->t->tok_id == PpPaste) { + /* + * We have found token pasting. If there is a series of such operators, + * make them all into one token pasting source and push it on + * the source stack. + */ + if (t->flag & LineChk) { + line_check = 1; + line = t->line; + fname = t->fname; + } + else + line_check = 0; + plst = paste_parse(t, me); + if (plst != NULL) { + ref.plsts = plst; + push_src(PasteLsts, &ref); + } + t1 = next_tok(); + if (line_check && !(t1->flag & LineChk)) { + t1->flag |= LineChk; + t1->line = line; + t1->fname = fname; + } + return t1; + } + else if (t->tok_id == Identifier && + (indx = parm_indx(t->image, me->m)) != -1) { + /* + * We have found a parameter. Push a token source for the corresponding + * argument, that is, replace the parameter with its definition. + */ + ref.tlst = me->exp_args[indx]; + push_src(TokLst, &ref); + if (t->flag & LineChk) { + line = t->line; + fname = t->fname; + t1 = next_tok(); + if (!(t1->flag & LineChk)) { + /* + * The parameter name token is significant with respect to + * outputting #line directives but the first argument token + * is not. Pretend the argument has the same line number as the + * parameter name. + */ + t1->flag |= LineChk; + t1->line = line; + t1->fname = fname; + } + free_t(t); + return t1; + } + else { + free_t(t); + return next_tok(); + } + } + else { + /* + * This is an ordinary token, nothing further is needed here. + */ + return t; + } + } diff --git a/src/preproc/pchars.c b/src/preproc/pchars.c new file mode 100644 index 0000000..5d1d00c --- /dev/null +++ b/src/preproc/pchars.c @@ -0,0 +1,157 @@ +#include "../preproc/preproc.h" +#include "../preproc/pproto.h" + +int *first_char; +int *next_char; +int *last_char; + +/* + * fill_cbuf - fill the current character buffer. + */ +void fill_cbuf() + { + register int c1, c2, c3; + register int *s; + register int *l; + int c; + int line; + int changes; + struct char_src *cs; + FILE *f; + + cs = src_stack->u.cs; + f = cs->f; + s = cs->char_buf; + l = cs->line_buf; + + if (next_char == NULL) { + /* + * Initial filling of buffer. + */ + first_char = cs->char_buf; + last_char = first_char + cs->bufsize - 3; + cs->last_char = last_char; + line = 1; + /* + * Get initial read-ahead. + */ + if ((c2 = getc(f)) != EOF) + c3 = getc(f); + } + else if (*next_char == EOF) + return; + else { + /* + * The calling routine needs at least 2 characters, so there is one + * left in the buffer. + */ + *s++= *next_char; + line = cs->line_buf[next_char - first_char]; + *l++ = line; + + /* + * Retrieve the 2 read-ahead characters that were saved the last + * time the buffer was filled. + */ + c2 = last_char[1]; + c3 = last_char[2]; + } + + next_char = first_char; + + /* + * Fill buffer from input file. + */ + while (s <= last_char) { + c1 = c2; + c2 = c3; + c3 = getc(f); + + /* + * The first phase of input translation is done here: trigraph + * translation and the deletion of backslash-newline pairs. + */ + changes = 1; + while (changes) { + changes = 0; + /* + * check for trigraphs + */ + if (c1 == '?' && c2 == '?') { + c = ' '; + switch (c3) { + case '=': + c = '#'; + break; + case '(': + c = '['; + break; + case '/': + c = '\\'; + break; + case ')': + c = ']'; + break; + case '\'': + c = '^'; + break; + case '<': + c = '{'; + break; + case '!': + c = '|'; + break; + case '>': + c = '}'; + break; + case '-': + c = '~'; + break; + } + /* + * If we found a trigraph, use it and refill the 2-character + * read-ahead. + */ + if (c != ' ') { + c1 = c; + if ((c2 = getc(f)) != EOF) + c3 = getc(f); + changes = 1; + } + } + + /* + * delete backslash-newline pairs + */ + if (c1 == '\\' && c2 == '\n') { + ++line; + if ((c1 = c3) != EOF) + if ((c2 = getc(f)) != EOF) + c3 = getc(f); + changes = 1; + } + } + if (c1 == EOF) { + /* + * If last character in file is not a new-line, insert one. + */ + if (s == first_char || s[-1] != '\n') + *s++ = '\n'; + *s = EOF; + last_char = s; + cs->last_char = last_char; + return; + } + if (c1 == '\n') + ++line; + *s++ = c1; /* put character in buffer */ + *l++ = line; + } + + /* + * Save the 2 character read-ahead in the reserved space at the end + * of the buffer. + */ + last_char[1] = c2; + last_char[2] = c3; + } diff --git a/src/preproc/perr.c b/src/preproc/perr.c new file mode 100644 index 0000000..9986111 --- /dev/null +++ b/src/preproc/perr.c @@ -0,0 +1,157 @@ +/* + * The functions in this file print error messages. + */ +#include "../preproc/preproc.h" +#include "../preproc/pproto.h" +extern char *progname; + +/* + * Prototypes for static functions. + */ +static void rm_files (void); + + +/* + * File list. + */ +struct finfo_lst { + char *name; /* file name */ + FILE *file; /* file */ + struct finfo_lst *next; /* next entry in list */ + }; + +static struct finfo_lst *file_lst = NULL; + +/* + * errt1 - error message in one string, location indicated by a token. + */ +void errt1(t, s) +struct token *t; +char *s; + { + errfl1(t->fname, t->line, s); + } + +/* + * errfl1 - error message in one string, location given by file and line. + */ +void errfl1(f, l, s) +char *f; +int l; +char *s; + { + fflush(stdout); + fprintf(stderr, "%s: File %s; Line %d: %s\n", progname, f, l, s); + rm_files(); + exit(EXIT_FAILURE); + } + +/* + * err1 - error message in one string, no location given + */ +void err1(s) +char *s; + { + fflush(stdout); + fprintf(stderr, "%s: %s\n", progname, s); + rm_files(); + exit(EXIT_FAILURE); + } + +/* + * errt2 - error message in two strings, location indicated by a token. + */ +void errt2(t, s1, s2) +struct token *t; +char *s1; +char *s2; + { + errfl2(t->fname, t->line, s1, s2); + } + +/* + * errfl2 - error message in two strings, location given by file and line. + */ +void errfl2(f, l, s1, s2) +char *f; +int l; +char *s1; +char *s2; + { + fflush(stdout); + fprintf(stderr, "%s: File %s; Line %d: %s%s\n", progname, f, l, s1, s2); + rm_files(); + exit(EXIT_FAILURE); + } + +/* + * err2 - error message in two strings, no location given + */ +void err2(s1, s2) +char *s1; +char *s2; + { + fflush(stdout); + fprintf(stderr, "%s: %s%s\n", progname, s1, s2); + rm_files(); + exit(EXIT_FAILURE); + } + +/* + * errt3 - error message in three strings, location indicated by a token. + */ +void errt3(t, s1, s2, s3) +struct token *t; +char *s1; +char *s2; +char *s3; + { + errfl3(t->fname, t->line, s1, s2, s3); + } + +/* + * errfl3 - error message in three strings, location given by file and line. + */ +void errfl3(f, l, s1, s2, s3) +char *f; +int l; +char *s1; +char *s2; +char *s3; + { + fflush(stdout); + fprintf(stderr, "%s: File %s; Line %d: %s%s%s\n", progname, f, l, + s1, s2, s3); + rm_files(); + exit(EXIT_FAILURE); + } + +/* + * addrmlst - add a file name to the list of files to be removed if + * an error occurs. + */ +void addrmlst(fname, f) +char *fname; +FILE *f; + { + struct finfo_lst *id; + + id = NewStruct ( finfo_lst ); + id->name = fname; + id->file = f; + id->next = file_lst; + file_lst = id; + } + +/* + * rm_files - remove files that must be cleaned up in the event of an + * error. + */ +static void rm_files() + { + while (file_lst != NULL) { + fclose ( file_lst->file ); + remove(file_lst->name); + file_lst = file_lst->next; + } + } diff --git a/src/preproc/pinit.c b/src/preproc/pinit.c new file mode 100644 index 0000000..9f64cb0 --- /dev/null +++ b/src/preproc/pinit.c @@ -0,0 +1,251 @@ +/* + * This file contains functions used to initialize the preprocessor, + * particularly those for establishing implementation-dependent standard + * macro definitions. + */ +#include "../preproc/preproc.h" +#include "../preproc/ptoken.h" +#include "../preproc/pproto.h" + +static void define_opt (char *s, int len, struct token *dflt); +static void do_directive (char *s); +static void mac_opts (char *opt_lst, char **opt_args); +static void undef_opt (char *s, int len); + +struct src dummy; + +/* + * init_preproc - initialize all parts of the preprocessor, establishing + * the primary file as the current source of tokens. + */ +void init_preproc(fname, opt_lst, opt_args) +char *fname; +char *opt_lst; +char **opt_args; + { + + init_str(); /* initialize string table */ + init_tok(); /* initialize tokenizer */ + init_macro(); /* initialize macro table */ + init_files(opt_lst, opt_args); /* initialize standard header locations */ + dummy.flag = DummySrc; /* marker at bottom of source stack */ + dummy.ntoks = 0; + src_stack = &dummy; + mac_opts(opt_lst, opt_args); /* process options for predefined macros */ + source(fname); /* establish primary source file */ + } + +/* + * mac_opts - handle options which affect what predefined macros are in + * effect when preprocessing starts. The options may be on the command + * line. Also establish predefined macros. + */ +static void mac_opts(opt_lst, opt_args) +char *opt_lst; +char **opt_args; + { + int i; + + /* + * Establish predefined macros. + */ + #if CYGWIN + do_directive("#define __CYGWIN32__\n"); + do_directive("#define __CYGWIN__\n"); + do_directive("#define __unix__\n"); + do_directive("#define __unix\n"); + do_directive("#define _WIN32\n"); + do_directive("#define __WIN32\n"); + do_directive("#define __WIN32__\n"); + #else /* CYGWIN */ + do_directive("#define unix 1\n"); + do_directive(PPInit); /* defines that vary between Unix systems */ + #endif /* CYGWIN*/ + + /* + * look for options that affect macro definitions (-U, -D, etc). + */ + for (i = 0; opt_lst[i] != '\0'; ++i) + switch(opt_lst[i]) { + case 'U': + /* + * Undefine and predefined identifier. + */ + undef_opt(opt_args[i], (int)strlen(opt_args[i])); + break; + + case 'D': + /* + * Define an identifier. Use "1" if no defining string is given. + */ + define_opt(opt_args[i], (int)strlen(opt_args[i]), one_tok); + break; + } + } + +/* + * str_src - establish a string, given by a character pointer and a length, + * as the current source of tokens. + */ +void str_src(src_name, s, len) +char *src_name; +char *s; +int len; + { + union src_ref ref; + int *ip1, *ip2; + + /* + * Create a character source with a large enought buffer for the string. + */ + ref.cs = new_cs(src_name, NULL, len + 1); + push_src(CharSrc, &ref); + ip1 = ref.cs->char_buf; + ip2 = ref.cs->line_buf; + while (len-- > 0) { + *ip1++ = *s++; /* copy string to source buffer */ + *ip2++ = 0; /* characters are from "line 0" */ + } + *ip1 = EOF; + *ip2 = 0; + ref.cs->next_char = ref.cs->char_buf; + ref.cs->last_char = ip1; + first_char = ref.cs->char_buf; + next_char = first_char; + last_char = ref.cs->last_char; + } + +/* + * do_directive - take a character string containing preprocessor + * directives separated by new-lines and execute them. This done + * by preprocessing the string. + */ +static void do_directive(s) +char *s; + { + str_src("", s, (int)strlen(s)); + while (interp_dir() != NULL) + ; + } + +/* + * undef_opt - take the argument to a -U option and, if it is valid, + * undefine it. + */ +static void undef_opt(s, len) +char *s; +int len; + { + struct token *mname; + int i; + + /* + * The name is needed in the form of a token. Use the preprocessor + * to tokenize it. + */ + str_src("", s, len); + mname = next_tok(); + if (mname == NULL || mname->tok_id != Identifier || + next_tok() != NULL) { + fprintf(stderr, "invalid argument to -U option: "); + for (i = 0; i < len; ++i) + putc(s[i], stderr); /* show offending argument */ + putc('\n', stderr); + show_usage(); + } + m_delete(mname); + } + +/* + * define_opt - take an argument to a -D option and, if it is valid, perform + * the requested definition. + */ +static void define_opt(s, len, dflt) +char *s; +int len; +struct token *dflt; + { + struct token *mname; + struct token *t; + struct tok_lst *body; + struct tok_lst **ptlst, **trail_whsp; + int i; + + /* + * The argument to -D must be tokenized. + */ + str_src("", s, len); + + /* + * Find the macro name. + */ + mname = next_tok(); + if (mname == NULL || mname->tok_id != Identifier) { + fprintf(stderr, "invalid argument to -D option: "); + for (i = 0; i < len; ++i) + putc(s[i], stderr); + putc('\n', stderr); + show_usage(); + } + + /* + * Determine if the name is followed by '='. + */ + if (chk_eq_sign()) { + /* + * Macro body is given, strip leading white space + */ + t = next_tok(); + if (t != NULL && t->tok_id == WhiteSpace) { + free_t(t); + t = next_tok(); + } + + + /* + * Construct the token list for body of macro. Keep track of trailing + * white space so it can be deleted. + */ + body = NULL; + ptlst = &body; + trail_whsp = NULL; + while (t != NULL) { + t->flag &= ~LineChk; + (*ptlst) = new_t_lst(t); + if (t->tok_id == WhiteSpace) + trail_whsp = ptlst; + else + trail_whsp = NULL; + ptlst = &(*ptlst)->next; + t = next_tok(); + } + + /* + * strip trailing white space + */ + if (trail_whsp != NULL) { + free_t_lst(*trail_whsp); + *trail_whsp = NULL; + } + } + else { + /* + * There is no '=' after the macro name; use the supplied + * default value for the macro definition. + */ + if (next_tok() == NULL) + if (dflt == NULL) + body = NULL; + else + body = new_t_lst(copy_t(dflt)); + else { + fprintf(stderr, "invalid argument to -D option: "); + for (i = 0; i < len; ++i) + putc(s[i], stderr); + putc('\n', stderr); + show_usage(); + } + } + + m_install(mname, NoArgs, 0, NULL, body); /* install macro definition */ + } diff --git a/src/preproc/pmain.c b/src/preproc/pmain.c new file mode 100644 index 0000000..9cc721a --- /dev/null +++ b/src/preproc/pmain.c @@ -0,0 +1,109 @@ +#include "../preproc/preproc.h" +#include "../preproc/pproto.h" + +char *progname = "pp"; + +/* + * Establish command-line options. + */ +static char *ostr = "+CPD:I:U:o:"; +static char *options = + "[-C] [-P] [-Dname[=[text]]] [-Uname] [-Ipath] [-ofile] [files]"; + +extern line_cntrl; + +/* + * getopt() variables + */ +extern int optind; /* index into parent argv vector */ +extern int optopt; /* character checked for validity */ +extern char *optarg; /* argument associated with option */ + +int main(argc, argv) +int argc; +char **argv; + { + int c; + char *opt_lst; + char **opt_args; + int nopts; + FILE *out_file; + + /* + * By default, keep the image of white space, but replace each comment + * by a space. By default, output #line directives. + */ + whsp_image = NoComment; + line_cntrl = 1; + + /* + * The number of options that must be passed on to other phases + * of the preprocessor are at most as large as the entire option + * list. + */ + opt_lst = alloc(argc); + opt_args = alloc(argc * sizeof (char *)); + nopts = 0; + out_file = stdout; + + /* + * Process options. + */ + while ((c = getopt(argc, argv, ostr)) != EOF) + switch (c) { + + case 'C': /* -C - retan comments */ + whsp_image = FullImage; + break; + + case 'P': /* -P - do not output #line directives */ + line_cntrl = 0; + break; + + case 'D': /* -D - predefine an identifier */ + case 'I': /* -I - location to search for standard header files */ + case 'U': /* -U - undefine predefined identifier */ + opt_lst[nopts] = c; + opt_args[nopts] = optarg; + ++nopts; + break; + + case 'o': /* -o - write output to this file */ + out_file = fopen(optarg, "w"); + if (out_file == NULL) + err2("cannot open output file ", optarg); + break; + + default: + show_usage(); + } + + opt_lst[nopts] = '\0'; + + /* + * Scan file name arguments. If there are none, process standard input, + * indicated by the name "-". + */ + if (optind == argc) { + init_preproc("-", opt_lst, opt_args); + output(out_file); + } + else { + while (optind < argc) { + init_preproc(argv[optind], opt_lst, opt_args); + output(out_file); + optind++; + } + } + + return EXIT_SUCCESS; + } + +/* + * Print an error message if called incorrectly. + */ +void show_usage() + { + fprintf(stderr, "usage: %s %s\n", progname, options); + exit(EXIT_FAILURE); + } diff --git a/src/preproc/pmem.c b/src/preproc/pmem.c new file mode 100644 index 0000000..c6f812e --- /dev/null +++ b/src/preproc/pmem.c @@ -0,0 +1,339 @@ +/* + * This file does most of the memory management. + */ + +#include "../preproc/preproc.h" +#include "../preproc/ptoken.h" + +struct src *src_stack = NULL; /* stack of token sources */ + +#include "../preproc/pproto.h" + +/* + * new_macro - allocate a new entry for the macro symbol table. + */ +struct macro *new_macro(mname, category, multi_line, prmlst, body) +char *mname; +int category; +int multi_line; +struct id_lst *prmlst; +struct tok_lst *body; + { + struct macro *mp; + + mp = NewStruct(macro); + mp->mname = mname; + mp->category = category; + mp->multi_line = multi_line; + mp->prmlst = prmlst; + mp->body = body; + mp->ref_cnt = 1; + mp->recurse = 0; + mp->next = NULL; + return mp; + } + +/* + * new_token - allocate a new token. + */ +struct token *new_token(id, image, fname, line) +int id; +char *image; +char *fname; +int line; + { + struct token *t; + + t = NewStruct(token); + t->tok_id = id; + t->image = image; + t->fname = fname; + t->line = line; + t->flag = 0; + return t; + } + +/* + * copy_t - make a copy of a token. + */ +struct token *copy_t(t) +struct token *t; + { + struct token *t1; + + if (t == NULL) + return NULL; + + t1 = NewStruct(token); + *t1 = *t; + return t1; + } + +/* + * new_t_lst - allocate a new element for a token list. + */ +struct tok_lst *new_t_lst(tok) +struct token *tok; + { + struct tok_lst *tlst; + + tlst = NewStruct(tok_lst); + tlst->t = tok; + tlst->next = NULL; + return tlst; + } + +/* + * new_id_lst - allocate a new element for an identifier list. + */ +struct id_lst *new_id_lst(id) +char *id; + { + struct id_lst *ilst; + + ilst = NewStruct(id_lst); + ilst->id = id; + ilst->next = NULL; + return ilst; + } + +/* + * new_cs - allocate a new structure for a source of tokens created from + * characters. + */ +struct char_src *new_cs(fname, f, bufsize) +char *fname; +FILE *f; +int bufsize; + { + struct char_src *cs; + + cs = NewStruct(char_src); + cs->char_buf = alloc(bufsize * sizeof(int)); + cs->line_buf = alloc(bufsize * sizeof(int)); + cs->bufsize = bufsize; + cs->fname = fname; + cs->f = f; + cs->line_adj = 0; + cs->tok_sav = NULL; + cs->dir_state = CanStart; + + return cs; + } + +/* + * new_me - allocate a new structure for a source of tokens derived + * from macro expansion. + */ +struct mac_expand *new_me(m, args, exp_args) +struct macro *m; +struct tok_lst **args; +struct tok_lst **exp_args; + { + struct mac_expand *me; + + me = NewStruct(mac_expand); + me->m = m; + me->args = args; + me->exp_args = exp_args; + me->rest_bdy = m->body; + return me; + } + +/* + * new_plsts - allocate a element for a list of token lists used as + * as source of tokens derived from a sequence of token pasting + * operations. + */ +struct paste_lsts *new_plsts(trigger, tlst, plst) +struct token *trigger; +struct tok_lst *tlst; +struct paste_lsts *plst; + { + struct paste_lsts *plsts; + + plsts = NewStruct(paste_lsts); + plsts->trigger = trigger; + plsts->tlst = tlst; + plsts->next = plst; + return plsts; + } + +/* + * get_sbuf - dynamically allocate a string buffer. + */ +struct str_buf *get_sbuf() + { + struct str_buf *sbuf; + + sbuf = NewStruct(str_buf); + init_sbuf(sbuf); + return sbuf; + } + +/* + * push_src - push an entry on the stack of tokens sources. This entry + * becomes the current source. + */ +void push_src(flag, ref) +int flag; +union src_ref *ref; + { + struct src *sp; + + sp = NewStruct(src); + sp->flag = flag; + sp->cond = NULL; + sp->u = *ref; + sp->ntoks = 0; + + if (src_stack->flag == CharSrc) + src_stack->u.cs->next_char = next_char; + sp->next = src_stack; + src_stack = sp; + } + +/* + * free_t - free a token. + */ +void free_t(t) +struct token *t; + { + if (t != NULL) + free((char *)t); + } + +/* + * free_t_lst - free a token list. + */ +void free_t_lst(tlst) +struct tok_lst *tlst; + { + if (tlst == NULL) + return; + free_t(tlst->t); + free_t_lst(tlst->next); + free((char *)tlst); + } + +/* + * free_id_lst - free an identifier list. + */ +void free_id_lst(ilst) +struct id_lst *ilst; + { + if (ilst == NULL) + return; + free_id_lst(ilst->next); + free((char *)ilst); + } + +/* + * free_m - if there are no more pointers to this macro entry, free it + * and other associated storage. + */ +void free_m(m) +struct macro *m; + { + if (--m->ref_cnt != 0) + return; + free_id_lst(m->prmlst); + free_t_lst(m->body); + free((char *)m); + } + +/* + * free_m_lst - free a hash chain of macro symbol table entries. + */ +void free_m_lst(m) +struct macro *m; + { + if (m == NULL) + return; + free_m_lst(m->next); + free_m(m); + } + +/* + * free_plsts - free an entry from a list of token lists used in + * token pasting. + */ +void free_plsts(plsts) +struct paste_lsts *plsts; + { + free((char *)plsts); + } + +/* + * rel_sbuf - free a string buffer. + */ +void rel_sbuf(sbuf) +struct str_buf *sbuf; + { + free((char *)sbuf); + } + +/* + * pop_src - pop the top entry from the stack of tokens sources. + */ +void pop_src() + { + struct src *sp; + struct char_src *cs; + struct mac_expand *me; + int i; + + if (src_stack->flag == DummySrc) + return; /* bottom of stack */ + + sp = src_stack; + src_stack = sp->next; /* pop */ + + /* + * If the new current source is a character source, reload global + * variables used in tokenizing the characters. + */ + if (src_stack->flag == CharSrc) { + first_char = src_stack->u.cs->char_buf; + next_char = src_stack->u.cs->next_char; + last_char = src_stack->u.cs->last_char; + } + + /* + * Make sure there is no unclosed conditional compilation in the + * source we are poping. + */ + if (sp->cond != NULL) + errt2(sp->cond->t, "no matching #endif for #", sp->cond->t->image); + + /* + * Free any storage that the stack entry still references. + */ + switch (sp->flag) { + case CharSrc: + cs = sp->u.cs; + if (cs->f != NULL) + fclose(cs->f); + free((char *)cs); + break; + case MacExpand: + me = sp->u.me; + if (me->args != NULL) { + for (i = 0; i < me->m->category; i++) { + free_t_lst(me->args[i]); + free_t_lst(me->exp_args[i]); + } + free((char *)me->args); + free((char *)me->exp_args); + } + --me->m->recurse; + free_m(me->m); + free((char *)me); + break; + } + + /* + * Free the stack entry. + */ + free((char *)sp); + } diff --git a/src/preproc/pout.c b/src/preproc/pout.c new file mode 100644 index 0000000..4f5fc32 --- /dev/null +++ b/src/preproc/pout.c @@ -0,0 +1,230 @@ +#include "../preproc/preproc.h" +#include "../preproc/ptoken.h" +#include "../preproc/pproto.h" + +int line_cntrl; + +/* + * output - output preprocessed tokens for the current file. + */ +void output(out_file) +FILE *out_file; + { + struct token *t, *t1; + struct token *saved_whsp; + char *fname; + char *s; + int line; + int nxt_line; + int trail_nl; /* flag: trailing character in output is a new-line */ + int blank_ln; /* flag: output ends with blank line */ + + fname = ""; + line = -1; + + /* + * Suppress an initial new-line in the output. + */ + trail_nl = 1; + blank_ln = 1; + + while ((t = preproc()) != NULL) { + if (t->flag & LineChk) { + /* + * This token is significant with respect to outputting #line + * directives. + */ + nxt_line = t->line; + if (fname != t->fname || line != nxt_line) { + /* + * We need a #line directive. Make sure it is preceeded by a + * blank line. + */ + if (!trail_nl) { + putc('\n', out_file); + ++line; + trail_nl = 1; + } + if (!blank_ln && (line != nxt_line || fname != t->fname)) { + putc('\n', out_file); + ++line; + blank_ln = 1; + } + /* + * Eliminate extra new-lines from the subsequent text before + * inserting line directive. This make the output look better. + * The line number for the directive will change if new-lines + * are eliminated. + */ + saved_whsp = NULL; + s = t->image; + while (t->tok_id == WhiteSpace && (*s == ' ' || *s == '\n' || + *s == '\t')) { + if (*s == '\n') { + /* + * Discard any white space before the new-line and update + * the line number. + */ + free_t(saved_whsp); + saved_whsp = NULL; + t->image = s + 1; + ++t->line; + ++nxt_line; + } + ++s; + if (*s == '\0') { + /* + * The end of the current white space token has been + * reached, see if the next token is also white space. + */ + free_t(saved_whsp); + t1 = preproc(); + if (t1 == NULL) { + /* + * We are at the end of the input. Don't output + * a #line directive, just make sure the output + * ends with a new-line. + */ + free_t(t); + if (!trail_nl) + putc('\n', out_file); + return; + } + /* + * The previous token may contain non-new-line white + * space, if the new token is on the same line, save + * that previous token in case we want to print the + * white space (this will correctly indent the new + * token). + */ + if (*(t->image) != '\0' && t->line == t1->line && + t->fname == t1->fname) + saved_whsp = t; + else { + free_t(t); + saved_whsp = NULL; + } + t = t1; + s = t->image; + nxt_line = t->line; + } + } + if (line_cntrl) { + /* + * We are supposed to insert #line directives where needed. + * However, one or two blank lines look better when they + * are enough to reestablish the correct line number. + */ + if (fname != t->fname || line > nxt_line || + line + 2 < nxt_line) { + /* + * Normally a blank line is put after the #line + * directive; However, this requires decrementing + * the line number and a line number of 0 is not + * valid. + */ + if (nxt_line > 1) + fprintf(out_file, "#line %d \"", nxt_line - 1); + else + fprintf(out_file, "#line %d \"", nxt_line); + for (s = t->fname; *s != '\0'; ++s) { + if (*s == '"' || *s == '\\') + putc('\\',out_file); + putc(*s, out_file); + } + fprintf(out_file, "\"\n"); + if (nxt_line > 1) + fprintf(out_file, "\n"); /* blank line after directive */ + trail_nl = 1; + blank_ln = 1; + } + else /* adjust line number with blank lines */ + while (line < nxt_line) { + putc('\n', out_file); + ++line; + if (trail_nl) + blank_ln = 1; + trail_nl = 1; + } + } + /* + * See if we need to indent the next token with white space + * saved while eliminating extra new-lines. + */ + if (saved_whsp != NULL) { + fprintf(out_file, "%s", saved_whsp->image); + free_t(saved_whsp); + if (trail_nl) { + blank_ln = 1; + trail_nl = 0; + } + } + line = t->line; + fname = t->fname; + } + } + + /* + * Print the image of the token. + */ + if (t->tok_id == WhiteSpace) { + /* + * Keep track of trailing blank lines and new-lines. This + * information is used to make the insertion of #line + * directives more intelligent and to insure that the output + * file ends with a new-line. + */ + for (s = t->image; *s != '\0'; ++s) { + putc(*s, out_file); + switch (*s) { + case '\n': + if (trail_nl) + blank_ln = 1; + trail_nl = 1; + ++line; + break; + + case ' ': + case '\t': + if (trail_nl) + blank_ln = 1; + trail_nl = 0; + break; + + default: + trail_nl = 0; + } + } + } + else { + /* + * Add delimiters to string and character literals. + */ + switch (t->tok_id) { + case StrLit: + fprintf(out_file, "\"%s\"", t->image); + break; + case LStrLit: + fprintf(out_file, "L\"%s\"", t->image); + break; + case CharConst: + fprintf(out_file, "'%s'", t->image); + break; + case LCharConst: + fprintf(out_file, "L'%s'", t->image); + break; + default: + fprintf(out_file, "%s", t->image); + } + trail_nl = 0; + blank_ln = 0; + } + free_t(t); + } + + /* + * Make sure output file ends with a new-line. + */ + if (!trail_nl) + putc('\n', out_file); + } diff --git a/src/preproc/pproto.h b/src/preproc/pproto.h new file mode 100644 index 0000000..492b7cb --- /dev/null +++ b/src/preproc/pproto.h @@ -0,0 +1,64 @@ +void addrmlst (char *fname, FILE *f); +void advance_tok (struct token **tp); +int chk_eq_sign (void); +long conditional (struct token **tp, struct token *trigger); +struct token *copy_t (struct token *t); +void err1 (char *s); +void err2 (char *s1, char *s2); +void errfl1 (char *f, int l, char *s); +void errfl2 (char *f, int l, char *s1, char *s2); +void errfl3 (char *f, int l, char *s1, char *s2, char *s3); +void errt1 (struct token *t, char *s); +void errt2 (struct token *t, char *s1, char *s2); +void errt3 (struct token *t, char *s1, char *s2, char *s3); +int eval (struct token *trigger); +void fill_cbuf (void); +void free_id_lst (struct id_lst *ilst); +void free_plsts (struct paste_lsts *plsts); +void free_m (struct macro *m); +void free_m_lst (struct macro *m); +void free_t (struct token *t); +void free_t_lst (struct tok_lst *tlst); +struct str_buf *get_sbuf (void); +void include (struct token *trigger, char *fname, int start); +void init_files (char *opt_lst,char * *opt_args); +void init_files (char *opt_lst,char * *opt_args); +void init_macro (void); +void init_preproc (char *fname, char *opt_lst, char **opt_args); +void init_sys (char *fname, int argc, char *argv[]); +void init_tok (void); +struct token *interp_dir (void); +struct token *mac_tok (void); +void merge_whsp (struct token **whsp, struct token **next_t, + struct token *(*t_src)(void)); +void m_delete (struct token *mname); +void m_install (struct token *mname, int category, + int multi_line, struct id_lst *prmlst, + struct tok_lst *body); +struct macro *m_lookup (struct token *mname); +struct char_src *new_cs (char *fname, FILE *f, int bufsize); +struct id_lst *new_id_lst (char *id); +struct macro *new_macro (char *mname, int category, + int multi_line, struct id_lst *prmlst, + struct tok_lst *body); +struct mac_expand *new_me (struct macro *m, struct tok_lst **args, + struct tok_lst **exp_args); +struct paste_lsts *new_plsts (struct token *trigger, + struct tok_lst *tlst, + struct paste_lsts *plst); +struct token *new_token (int id, char *image, char *fname, + int line); +struct tok_lst *new_t_lst (struct token *tok); +struct token *next_tok (void); +void nxt_non_wh (struct token **tp); +void output (FILE *out_file); +struct token *paste (void); +void pop_src (void); +struct token *preproc (void); +void push_src (int flag, union src_ref *ref); +void rel_sbuf (struct str_buf *sbuf); +int rt_state (int tok_id); +void show_usage (void); +void source (char *fname); +void str_src (char *src_name, char *s, int len); +struct token *tokenize (void); diff --git a/src/preproc/preproc.c b/src/preproc/preproc.c new file mode 100644 index 0000000..01fb97c --- /dev/null +++ b/src/preproc/preproc.c @@ -0,0 +1,991 @@ +/* + * The functions in this file handle preprocessing directives, macro + * calls, and string concatenation. + */ +#include "../preproc/preproc.h" +#include "../preproc/ptoken.h" +#include "../preproc/pproto.h" + +/* + * Prototypes for static functions. + */ +static void start_select (struct token *t); +static void end_select (struct token *t); +static void incl_file (struct token *t); +static void define (struct token *t); +static int expand (struct token *t, struct macro *m); +static void toks_to_str (struct str_buf *sbuf, struct token *t); + +/* + * start_select - handle #if, #ifdef, #ifndef + */ +static void start_select(t) +struct token *t; + { + struct token *t1; + struct tok_lst *tlst; + int condition; + int nesting; + + /* + * determine if condition is true. + */ + if (t->tok_id == PpIf) + condition = eval(t); /* #if - evaluate expression */ + else { + /* + * #ifdef or #ifndef - see if an identifier is defined. + */ + t1 = NULL; + nxt_non_wh(&t1); + if (t1->tok_id != Identifier) + errt2(t1, "identifier must follow #", t->image); + condition = (m_lookup(t1) == NULL) ? 0 : 1; + if (t->tok_id == PpIfndef) + condition = !condition; + free_t(t1); + t1 = next_tok(); + if (t1->tok_id != PpDirEnd) + errt2(t1, "expecting end of line following argument to #", t->image); + free_t(t1); + } + + /* + * look for the branch of the conditional inclusion to take or #endif. + */ + nesting = 0; + while (!condition) { + t1 = next_tok(); + if (t1 == NULL) + errt2(t, "no matching #endif for #", t->image); + switch (t1->tok_id) { + case PpIf: + case PpIfdef: + case PpIfndef: + /* + * Nested #if, #ifdef, or #ifndef in a branch of a conditional + * that is being discarded. Contunue discarding until the + * nesting level returns to 0. + */ + ++nesting; + break; + + case PpEndif: + /* + * #endif found. See if this is this the end of a nested + * conditional or the end of the conditional we are processing. + */ + if (nesting > 0) + --nesting; + else { + /* + * Discard any extraneous tokens on the end of the directive. + */ + while (t->tok_id != PpDirEnd) { + free_t(t); + t = next_tok(); + } + free_t(t); + free_t(t1); + return; + } + break; + + case PpElif: + /* + * #elif found. If this is not a nested conditional, see if + * it has a true condition. + */ + if (nesting == 0) { + free_t(t); + t = t1; + t1 = NULL; + condition = eval(t); + } + break; + + case PpElse: + /* + * #else found. If this is not a nested conditional, take + * this branch. + */ + if (nesting == 0) { + free_t(t); + t = t1; + t1 = next_tok(); + /* + * Discard any extraneous tokens on the end of the directive. + */ + while (t1->tok_id != PpDirEnd) { + free_t(t1); + t1 = next_tok(); + } + condition = 1; + } + } + free_t(t1); + } + tlst = new_t_lst(t); + tlst->next = src_stack->cond; + src_stack->cond = tlst; + } + +/* + * end_select - handle #elif, #else, and #endif + */ +static void end_select(t) +struct token *t; + { + struct tok_lst *tlst; + struct token *t1; + int nesting; + + /* + * Make sure we are processing conditional compilation and pop it + * from the list of conditional nesting. + */ + tlst = src_stack->cond; + if (tlst == NULL) + errt2(t, "invalid context for #", t->image); + src_stack->cond = tlst->next; + tlst->next = NULL; + free_t_lst(tlst); + + /* + * We are done with the selected branch for the conditional compilation. + * Skip to the matching #endif (if we are not already there). Don't + * be confused by nested conditionals. + */ + nesting = 0; + t1 = copy_t(t); + while (t1->tok_id != PpEndif || nesting > 0) { + switch (t1->tok_id) { + case PpIf: + case PpIfdef: + case PpIfndef: + ++nesting; + break; + + case PpEndif: + --nesting; + } + free_t(t1); + t1 = next_tok(); + if (t1 == NULL) + errt2(t, "no matching #endif for #", t->image); + } + free_t(t); + + /* + * Discard any extraneous tokens on the end of the #endif directive. + */ + while (t1->tok_id != PpDirEnd) { + free_t(t1); + t1 = next_tok(); + } + free_t(t1); + return; + } + +/* + * incl_file - handle #include + */ +static void incl_file(t) +struct token *t; + { + struct token *file_tok, *t1; + struct str_buf *sbuf; + char *s; + char *fname; + int line; + + file_tok = NULL; + advance_tok(&file_tok); + + /* + * Determine what form the head file name takes. + */ + if (file_tok->tok_id != StrLit && file_tok->tok_id != PpHeader) { + /* + * see if macro expansion created a name of the form <...> + */ + t1 = file_tok; + s = t1->image; + fname = t1->fname; + line = t1->line; + if (*s != '<') + errt1(t1, "invalid include file syntax"); + ++s; + + /* + * Gather into a string buffer the characters from subsequent tokens + * until the closing '>' is found, then create a "header" token + * from it. + */ + sbuf = get_sbuf(); + while (*s != '>') { + while (*s != '\0' && *s != '>') + AppChar(*sbuf, *s++); + if (*s == '\0') { + switch (t1->tok_id) { + case StrLit: + case LStrLit: + AppChar(*sbuf, '"'); + break; + case CharConst: + case LCharConst: + AppChar(*sbuf, '\''); + break; + } + free_t(t1); + t1 = interp_dir(); + switch (t1->tok_id) { + case StrLit: + AppChar(*sbuf, '"'); + break; + case LStrLit: + AppChar(*sbuf, 'L'); + AppChar(*sbuf, '"'); + break; + case CharConst: + AppChar(*sbuf, '\''); + break; + case LCharConst: + AppChar(*sbuf, 'L'); + AppChar(*sbuf, '\''); + break; + case PpDirEnd: + errt1(t1, "invalid include file syntax"); + } + if (t1->tok_id == WhiteSpace) + AppChar(*sbuf, ' '); + else + s = t1->image; + } + } + if (*++s != '\0') + errt1(t1, "invalid include file syntax"); + free_t(t1); + file_tok = new_token(PpHeader, str_install(sbuf), fname, line); + rel_sbuf(sbuf); + } + + t1 = interp_dir(); + if (t1->tok_id != PpDirEnd) + errt1(t1, "invalid include file syntax"); + free_t(t1); + + /* + * Add the file to the top of the token source stack. + */ + if (file_tok->tok_id == StrLit) + include(t, file_tok->image, 0); + else + include(t, file_tok->image, 1); + free_t(file_tok); + free_t(t); + } + +/* + * define - handle #define and #begdef + */ +static void define(t) +struct token *t; + { + struct token *mname; /* name of macro */ + int category; /* NoArgs for object-like macro, else number params */ + int multi_line; + struct id_lst *prmlst; /* parameter list */ + struct tok_lst *body; /* replacement list */ + struct token *t1; + struct id_lst **pilst; + struct tok_lst **ptlst; + int nesting; + + /* + * Get the macro name. + */ + mname = NULL; + nxt_non_wh(&mname); + if (mname->tok_id != Identifier) + errt2(mname, "syntax error in #", t->image); + + /* + * Determine if this macro takes arguments. + */ + prmlst = NULL; + t1 = next_tok(); + if (t1->tok_id == '(') { + /* + * function like macro - gather parameter list + */ + pilst = &prmlst; + nxt_non_wh(&t1); + if (t1->tok_id == Identifier) { + category = 1; + (*pilst) = new_id_lst(t1->image); + pilst = &(*pilst)->next; + nxt_non_wh(&t1); + while (t1->tok_id == ',') { + nxt_non_wh(&t1); + if (t1->tok_id != Identifier) + errt1(t1, "a parameter to a macro must be an identifier"); + ++category; + (*pilst) = new_id_lst(t1->image); + pilst = &(*pilst)->next; + nxt_non_wh(&t1); + } + } + else + category = 0; + if (t1->tok_id != ')') + errt2(t1, "syntax error in #", t->image); + free_t(t1); + t1 = next_tok(); + } + else + category = NoArgs; /* object-like macro */ + + /* + * Gather the body of the macro. + */ + body = NULL; + ptlst = &body; + if (t->tok_id == PpDefine) { /* #define */ + multi_line = 0; + /* + * strip leading white space + */ + while (t1->tok_id == WhiteSpace) { + free_t(t1); + t1 = next_tok(); + } + + while (t1->tok_id != PpDirEnd) { + /* + * Expansion of this type of macro does not trigger #line directives. + */ + t1->flag &= ~LineChk; + + (*ptlst) = new_t_lst(t1); + ptlst = &(*ptlst)->next; + t1 = next_tok(); + } + } + else { + /* + * #begdef + */ + multi_line = 1; + if (t1->tok_id != PpDirEnd) + errt1(t1, "expecting new-line at end of #begdef"); + free_t(t1); + + /* + * Gather tokens until #enddef. Nested #begdef-#enddefs are put + * in this macro and not processed until the macro is expanded. + */ + nesting = 0; + t1 = next_tok(); + while (t1 != NULL && (nesting > 0 || t1->tok_id != PpEnddef)) { + if (t1->tok_id == PpBegdef) + ++nesting; + else if (t1->tok_id == PpEnddef) + --nesting; + (*ptlst) = new_t_lst(t1); + ptlst = &(*ptlst)->next; + t1 = next_tok(); + } + if (t1 == NULL) + errt1(t, "unexpected end-of-file in #begdef"); + free_t(t1); + t1 = next_tok(); + if (t1->tok_id != PpDirEnd) + errt1(t1, "expecting new-line at end of #enddef"); + } + free_t(t1); + free_t(t); + + /* + * Install the macro in the macro symbol table. + */ + m_install(mname, category, multi_line, prmlst, body); + free_t(mname); + } + +/* + * expand - add expansion of macro to source stack. + */ +static int expand(t, m) +struct token *t; +struct macro *m; + { + struct token *t1 = NULL; + struct token *t2; + struct token *whsp = NULL; + union src_ref ref; + struct tok_lst **args, **exp_args; + struct tok_lst **tlp, **trail_whsp; + struct src *stack_sav; + int nparm; + int narg; + int paren_nest; + int line; + char *fname; + + ++m->ref_cnt; + + args = NULL; + exp_args = NULL; + if (m->category >= 0) { + /* + * This macro requires an argument list. Gather it, if there is one. + */ + nparm = m->category; + narg = 0; + merge_whsp(&whsp, &t1, next_tok); + if (t1 == NULL || t1->tok_id != '(') { + /* + * There is no argument list. Do not expand the macro, just push + * back the tokens we read ahead. + */ + if (t1 != NULL) + src_stack->toks[src_stack->ntoks++] = t1; + if (whsp != NULL) + src_stack->toks[src_stack->ntoks++] = whsp; + --m->ref_cnt; + return 0; + } + free_t(whsp); + + /* + * See how many arguments we expect. + */ + if (nparm == 0) + nxt_non_wh(&t1); + else { + /* + * Allocate an array for both raw and macro-expanded token lists + * for the arguments. + */ + args = alloc(nparm * sizeof(struct tok_lst *)); + exp_args = alloc(nparm * sizeof(struct tok_lst *)); + + /* + * Gather the tokens for each argument. + */ + paren_nest = 0; + for ( ; narg < nparm && t1 != NULL && t1->tok_id != ')'; ++narg) { + /* + * Strip leading white space from the argument. + */ + nxt_non_wh(&t1); + tlp = &args[narg]; /* location of raw token list for this arg */ + *tlp = NULL; + trail_whsp = NULL; + /* + * Gather tokens for this argument. + */ + while (t1 != NULL && (paren_nest > 0 || (t1->tok_id != ',' && + t1->tok_id != ')'))) { + if (t1->tok_id == '(') + ++paren_nest; + if (t1->tok_id == ')') + --paren_nest; + t1->flag &= ~LineChk; + + /* + * Link this token into the list for the argument. If this + * might be trailing white space, remember where the pointer + * to it is so it can be discarded later. + */ + *tlp = new_t_lst(t1); + if (t1->tok_id == WhiteSpace) { + if (trail_whsp == NULL) + trail_whsp = tlp; + } + else + trail_whsp = NULL; + tlp = &(*tlp)->next; + t1 = next_tok(); + } + /* + * strip trailing white space + */ + if (trail_whsp != NULL) { + free_t_lst(*trail_whsp); + *trail_whsp = NULL; + } + + /* + * Create a macro expanded token list for the argument. This is + * done by establishing a separate preprocessing context with + * a new source stack. The current stack must be be saved and + * restored. + */ + tlp = &exp_args[narg]; /* location of expanded token list for arg */ + *tlp = NULL; + if (src_stack->flag == CharSrc) + src_stack->u.cs->next_char = next_char; /* save state */ + stack_sav = src_stack; + src_stack = &dummy; + ref.tlst = args[narg]; + push_src(TokLst, &ref); /* initial stack is list of raw tokens */ + /* + * Get macro expanded tokens. + */ + for (t2 = interp_dir(); t2 != NULL; t2 = interp_dir()) { + *tlp = new_t_lst(t2); + tlp = &(*tlp)->next; + } + src_stack = stack_sav; + if (src_stack->flag == CharSrc) { + /* + * Restore global state for tokenizing. + */ + first_char = src_stack->u.cs->char_buf; + next_char = src_stack->u.cs->next_char; + last_char = src_stack->u.cs->last_char; + } + } + } + if (t1 == NULL) + errt2(t, "unexpected end-of-file in call to macro ", t->image); + if (t1->tok_id != ')') + errt2(t1, "too many arguments for macro call to ", t->image); + if (narg < nparm) + errt2(t1, "too few arguments for macro call to ", t->image); + free_t(t1); + } + + ++m->recurse; + ref.me = new_me(m, args, exp_args); + push_src(MacExpand, &ref); + /* + * Don't loose generation of #line directive before regular + * macros, if there should be one. + */ + if (!m->multi_line && (t->flag & LineChk)) { + line = t->line; + fname = t->fname; + t1 = next_tok(); + if (t1 != NULL) { + if (!(t1->flag & LineChk)) { + t1->flag |= LineChk; + t1->line = line; + t1->fname = fname; + } + src_stack->toks[src_stack->ntoks++] = t1; + } + } + return 1; + } + +/* + * toks_to_str - put in a buffer the string image of tokens up to the end of + * of a preprocessor directive. + */ +static void toks_to_str(sbuf, t) +struct str_buf *sbuf; +struct token *t; + { + char *s; + + while (t->tok_id != PpDirEnd) { + if (t->tok_id == WhiteSpace) + AppChar(*sbuf, ' '); + else { + if (t->tok_id == LCharConst || t->tok_id == LStrLit) + AppChar(*sbuf, 'L'); + if (t->tok_id == CharConst || t->tok_id == LCharConst) + AppChar(*sbuf, '\''); + else if (t->tok_id == StrLit || t->tok_id == LStrLit) + AppChar(*sbuf, '"'); + for (s = t->image; *s != '\0'; ++s) + AppChar(*sbuf, *s); + if (t->tok_id == CharConst || t->tok_id == LCharConst) + AppChar(*sbuf, '\''); + else if (t->tok_id == StrLit || t->tok_id == LStrLit) + AppChar(*sbuf, '"'); + } + free_t(t); + t = next_tok(); + } + free_t(t); + } + +/* + * interp_dir - interpret preprocessing directives and recognize macro calls. + */ +struct token *interp_dir() + { + struct token *t, *t1; + struct macro *m; + struct str_buf *sbuf; + char *s; + + /* + * See if the caller pushed back any tokens + */ + if (src_stack->ntoks > 0) + return src_stack->toks[--src_stack->ntoks]; + + for (;;) { + t = next_tok(); + if (t == NULL) + return NULL; + + switch (t->tok_id) { + case PpIf: /* #if */ + case PpIfdef: /* #ifdef */ + case PpIfndef: /* #endif */ + start_select(t); + break; + + case PpElif: /* #elif */ + case PpElse: /* #else */ + case PpEndif: /* #endif */ + end_select(t); + break; + + case PpInclude: /* #include */ + incl_file(t); + break; + + case PpDefine: /* #define */ + case PpBegdef: /* #begdef */ + define(t); + break; + + case PpEnddef: /* #endif, but we have not seen an #begdef */ + errt1(t, "invalid context for #enddef"); + + case PpUndef: /* #undef */ + /* + * Get the identifier and delete it from the macro symbol table. + */ + t1 = NULL; + nxt_non_wh(&t1); + if (t1->tok_id != Identifier) + errt1(t1, "#undef requires an identifier argument"); + m_delete(t1); + free_t(t1); + t1 = next_tok(); + if (t1->tok_id != PpDirEnd) + errt1(t1, "syntax error for #undef"); + free_t(t1); + free_t(t); + break; + + case PpLine: /* #line */ + /* this directive is handled in next_tok() */ + break; + + case PpError: /* #error */ + /* + * Create an error message out of the rest of the tokens + * in this directive. + */ + sbuf = get_sbuf(); + t1 = NULL; + nxt_non_wh(&t1); + toks_to_str(sbuf, t1); + errt1(t, str_install(sbuf)); + break; + + case PpPragma: /* #pramga */ + case PpSkip: + /* + * Ignore all pragmas and all non-ANSI directives that need not + * be passed to the caller. + */ + t1 = next_tok(); + while (t1->tok_id != PpDirEnd) { + free_t(t1); + t1 = next_tok(); + } + free_t(t); + free_t(t1); + break; + + case PpKeep: + /* + * This is a directive special to an application using + * this preprocessor. Pass it on to the application. + */ + sbuf = get_sbuf(); + AppChar(*sbuf, '#'); + for (s = t->image; *s != '\0'; ++s) + AppChar(*sbuf, *s); + toks_to_str(sbuf, next_tok()); + t->image = str_install(sbuf); + rel_sbuf(sbuf); + return t; + + case PpNull: /* # */ + free_t(t); + free_t(next_tok()); /* must be PpDirEnd */ + break; + + default: + /* + * This is not a directive, see if it is a macro name. + */ + if (t->tok_id == Identifier && !(t->flag & NoExpand) && + (m = m_lookup(t)) != NULL) { + if (max_recurse < 0 || m->recurse < max_recurse) { + if (expand(t, m)) + free_t(t); + else + return t; + } + else { + t->flag |= NoExpand; + return t; + } + } + else + return t; /* nothing special, just return it */ + } + } + } + +/* + * See if compiler used to build the preprocessor recognizes '\a' + * as the bell character. + */ + +#if '\a' == Bell + + #define TokSrc interp_dir + +#else /* '\a' == Bell */ + + #define TokSrc check_bell + + /* + * fix_bell - replace \a characters which correct octal escape sequences. + */ + static char *fix_bell(s) + register char *s; + { + struct str_buf *sbuf; + + sbuf = get_sbuf(); + while (*s != '\0') { + AppChar(*sbuf, *s); + if (*s == '\\') { + ++s; + if (*s == 'a') { + AppChar(*sbuf, '0' + ((Bell >> 6) & 7)); + AppChar(*sbuf, '0' + ((Bell >> 3) & 7)); + AppChar(*sbuf, '0' + (Bell & 7)); + } + else + AppChar(*sbuf, *s); + } + ++s; + } + s = str_install(sbuf); + rel_sbuf(sbuf); + return s; + } + + /* + * check_bell - check for \a in character and string constants. This is only + * used with compilers which don't give the standard interpretation to \a. + */ + static struct token *check_bell() + { + struct token *t; + register char *s; + + t = interp_dir(); + if (t == NULL) + return NULL; + switch (t->tok_id) { + case StrLit: + case LStrLit: + case CharConst: + case LCharConst: + s = t->image; + while (*s != '\0') { + if (*s == '\\') { + if (*++s == 'a') { + /* + * There is at least one \a to replace. + */ + t->image = fix_bell(t->image); + break; + } + } + ++s; + } + } + return t; + } + +#endif /* '\a' == Bell */ + +/* + * preproc - return the next fully preprocessed token. + */ +struct token *preproc() + { + struct token *t1, *whsp, *t2, *str; + struct str_buf *sbuf; + int i; + char *escape_seq; + char *s; + char hex_char; + int is_hex_char; + + t1 = TokSrc(); + if (t1 == NULL) + return NULL; /* end of file */ + + /* + * Concatenate adjacent strings. There is a potential problem if the + * first string ends in a octal or hex constant and the second string + * starts with a corresponding digit. For example the strings "\12" + * and "7" should be concatenated to produce the 2 character string + * "\0127" not the one character string "\127". When such a situation + * arises, the last character of the first string is converted to a + * canonical 3-digit octal form. + */ + if (t1->tok_id == StrLit || t1->tok_id == LStrLit) { + /* + * See what the next non-white space token is, but don't discard any + * white space yet. + */ + whsp = NULL; + merge_whsp(&whsp, &t2, TokSrc); + if (t2 != NULL && (t2->tok_id == StrLit || t2->tok_id == LStrLit)) { + /* + * There are at least two adjacent string literals, concatenate them. + */ + sbuf = get_sbuf(); + str = copy_t(t1); + while (t2 != NULL && (t2->tok_id == StrLit || t2->tok_id == LStrLit)) { + s = t1->image; + while (*s != '\0') { + if (*s == '\\') { + AppChar(*sbuf, *s); + ++s; + if (*s == 'x') { + /* + * Hex escape sequence. + */ + hex_char = 0; + escape_seq = s; + ++s; + is_hex_char = 1; + while (is_hex_char) { + if (*s >= '0' && *s <= '9') + hex_char = (hex_char << 4) | (*s - '0'); + else switch (*s) { + case 'a': case 'A': + hex_char = (hex_char << 4) | 10; + break; + case 'b': case 'B': + hex_char = (hex_char << 4) | 11; + break; + case 'c': case 'C': + hex_char = (hex_char << 4) | 12; + break; + case 'd': case 'D': + hex_char = (hex_char << 4) | 13; + break; + case 'e': case 'E': + hex_char = (hex_char << 4) | 14; + break; + case 'f': case 'F': + hex_char = (hex_char << 4) | 15; + break; + default: is_hex_char = 0; + } + if (is_hex_char) + ++s; + } + /* + * If this escape sequence is at the end of the + * string and the next string starts with a + * hex digit, use the canonical form, otherwise + * use it as is. + */ + if (*s == '\0' && isxdigit(t2->image[0])) { + AppChar(*sbuf, ((hex_char >> 6) & 03) + '0'); + AppChar(*sbuf, ((hex_char >> 3) & 07) + '0'); + AppChar(*sbuf, (hex_char & 07) + '0'); + } + else + while (escape_seq != s) + AppChar(*sbuf, *escape_seq++); + } + else if (*s >= '0' && *s <= '7') { + /* + * Octal escape sequence. + */ + escape_seq = s; + i = 1; + while (i <= 3 && *s >= '0' && *s <= '7') { + ++i; + ++s; + } + /* + * If this escape sequence is at the end of the + * string and the next string starts with an + * octal digit, extend it to 3 digits, otherwise + * use it as is. + */ + if (*s == '\0' && t2->image[0] >= '0' && + t2->image[0] <= '7' && i <= 3) { + AppChar(*sbuf, '0'); + if (i <= 2) + AppChar(*sbuf, '0'); + } + while (escape_seq != s) + AppChar(*sbuf, *escape_seq++); + } + } + else { + /* + * Not an escape sequence, just copy the character to the + * buffer. + */ + AppChar(*sbuf, *s); + ++s; + } + } + free_t(t1); + t1 = t2; + + /* + * Get the next non-white space token, saving any skipped + * white space. + */ + merge_whsp(&whsp, &t2, TokSrc); + } + + /* + * Copy the image of the last token into the buffer, creating + * the image for the concatenated token. + */ + for (s = t1->image; *s != '\0'; ++s) + AppChar(*sbuf, *s); + str->image = str_install(sbuf); + free_t(t1); + t1 = str; + rel_sbuf(sbuf); + } + + /* + * Push back any look-ahead tokens. + */ + if (t2 != NULL) + src_stack->toks[src_stack->ntoks++] = t2; + if (whsp != NULL) + src_stack->toks[src_stack->ntoks++] = whsp; + } + return t1; + } diff --git a/src/preproc/preproc.h b/src/preproc/preproc.h new file mode 100644 index 0000000..8cc495f --- /dev/null +++ b/src/preproc/preproc.h @@ -0,0 +1,202 @@ +#include "../h/gsupport.h" + +/* + * If Bell is not defined, determine the default value for the "bell" + * character. + */ +#ifndef Bell +#define Bell '\a' +#endif /* Bell */ + +#define CBufSize 256 /* size of buffer for file input */ + +/* + * Identification numbers for tokens for which there are no definitions + * generated from a C grammar by yacc. + */ +#define WhiteSpace 1001 /* white space */ +#define PpNumber 1002 /* number (integer or real) */ +#define PpIf 1003 /* #if */ +#define PpElse 1004 /* #else */ +#define PpIfdef 1005 /* #ifdef */ +#define PpIfndef 1006 /* #ifndef */ +#define PpElif 1007 /* #elif */ +#define PpEndif 1008 /* #endif */ +#define PpInclude 1009 /* #include */ +#define PpDefine 1010 /* #define */ +#define PpUndef 1011 /* #undef */ +#define PpLine 1012 /* #line */ +#define PpError 1013 /* #error */ +#define PpPragma 1014 /* #pragma */ +#define PpPaste 1015 /* ## */ +#define PpDirEnd 1016 /* new-line terminating a directive */ +#define PpHeader 1017 /* <...> from #include */ +#define PpBegdef 1018 /* #begdef */ +#define PpEnddef 1019 /* #enddef */ +#define PpNull 1020 /* # */ +#define PpKeep 1021 /* directive specific to an application, pass along */ +#define PpSkip 1022 /* directive specific to an application discard */ +#define Invalid 9999 /* marker */ + +extern char *progname; /* name of this program: for error messages */ +extern int line_cntrl; /* flag: are line directives needed in the output */ + +/* + * whsp_image determines whether the spelling of white space is not retained, + * is retained with each comment replaced by a space, or the full spelling + * of white space and comments is retained. + */ +#define NoSpelling 0 +#define NoComment 1 +#define FullImage 2 + +extern int whsp_image; + +extern int max_recurse; /* how much recursion is allows in macros */ +extern struct token *zero_tok; /* token "0" */ +extern struct token *one_tok; /* token "1" */ + +extern int *first_char; /* first character in tokenizing buffer */ +extern int *next_char; /* next character in tokenizing buffer */ +extern int *last_char; /* last character in tokenizing buffer */ + +/* + * Entry in array of preprocessor directive names. + */ +struct rsrvd_wrd { + char *s; /* name (without the #) */ + int tok_id; /* token id of directive */ + }; + +/* + * token flags: + */ +#define LineChk 0x1 /* A line directive may be needed in the output */ +#define NoExpand 0x2 /* Don't macro expand this identifier */ + +/* + * Token. + */ +struct token { + int tok_id; /* token identifier */ + char *image; /* string image of token */ + char *fname; /* file name of origin */ + int line; /* line number of origin */ + int flag; /* token flag, see above */ + }; + +/* + * Token list. + */ +struct tok_lst { + struct token *t; /* token */ + struct tok_lst *next; /* next entry in list */ + }; + +/* + * Identifier list. + */ +struct id_lst { + char *id; /* identifier */ + struct id_lst *next; /* next entry in list */ + }; + +/* + * a macro, m, falls into one of several categores: + * those with arguments - m.category = # args >= 0 + * those with no arguments - m.category = NoArgs + * those that may not be chaged - m.category = FixedMac + * those that require special handling - m.category = SpecMac + */ +#define NoArgs -1 +#define FixedMac -2 +#define SpecMac -3 + +struct macro { + char *mname; + int category; + int multi_line; + struct id_lst *prmlst; + struct tok_lst *body; + int ref_cnt; + int recurse; + struct macro *next; + }; + +/* + * states for recognizing preprocessor directives + */ +#define Reset 1 +#define CanStart 2 /* Just saw a new-line, look for a directive */ +#define Within 3 /* Next new-line ends directive */ + +/* + * Information for a source of tokens created from a character stream. + * The characters may come from a file, or they be in a prefilled buffer. + */ +struct char_src { + FILE *f; /* file, if the chars come directly from a file */ + char *fname; /* name of file */ + int bufsize; /* size of character buffer */ + int *char_buf; /* pointer to character buffer */ + int *line_buf; /* buffer of lines characters come from */ + int *next_char; /* next unprocessed character in buffer */ + int *last_char; /* last character in buffer */ + int line_adj; /* line adjustment caused by #line directive */ + int dir_state; /* state w.r.t. recognizing directives */ + struct token *tok_sav; /* used to save token after look ahead */ + }; + +/* + * Information for a source of tokens dirived from expanding a macro. + */ +struct mac_expand { + struct macro *m; /* the macro being expanded */ + struct tok_lst **args; /* list of arguments for macro call */ + struct tok_lst **exp_args; /* list of expanded arguments for macro call */ + struct tok_lst *rest_bdy; /* position within the body of the macro */ + }; + +/* + * Elements in a list of token lists used for token pasting. + */ +struct paste_lsts { + struct token *trigger; /* the token pasting operator */ + struct tok_lst *tlst; /* the token list */ + struct paste_lsts *next; /* the next element in the list of lists */ +}; + +/* + * Pointers to various token sources. + */ +union src_ref { + struct char_src *cs; /* source is tokenized characters */ + struct mac_expand *me; /* source is macro expansion */ + struct tok_lst *tlst; /* source is token list (a macro argument) */ + struct paste_lsts *plsts; /* source is token lists for token pasting */ + }; + +/* + * Types of token sources: + */ +#define CharSrc 0 /* tokenized characters */ +#define MacExpand 1 /* macro expansion */ +#define TokLst 2 /* token list */ +#define PasteLsts 4 /* paste last token of 1st list to first of 2nd */ +#define DummySrc 5 /* base of stack */ + +#define NTokSav 2 /* maximum number of tokens that can be pushed back */ + +struct src { + int flag; /* indicate what kind of source it is */ + struct tok_lst *cond; /* list of nested conditionals in effect */ + struct token *toks[NTokSav]; /* token push-back stack for preproc() */ + int ntoks; /* number of tokens on stack */ + struct src *next; /* link for creating stack */ + union src_ref u; /* pointer to specific kind of source */ + }; + +extern struct src dummy; /* base of stack */ + +extern struct src *src_stack; /* source stack */ + diff --git a/src/preproc/ptoken.h b/src/preproc/ptoken.h new file mode 100644 index 0000000..35cf2b3 --- /dev/null +++ b/src/preproc/ptoken.h @@ -0,0 +1,48 @@ +/* + * The #defines for tokens can be overridden by a -DTokDotH=... compiler + * option. This specifies a file containing token #defines and is useful + * for creating an embedded preprocessor where token definitions are + * generated by yacc from a grammar. + * + * Otherwise, the default token definitions are RTT's; if NoRTT is + * defined, then this file's definitions are used. + */ +#ifdef TokDotH +#include TokDotH +#else /* TokDotH */ +#ifndef NoRTT +#include "../rtt/ltoken.h" +#else /* RTT */ +/* + * These are the numbers for tokens (other than single characters) returned + * by the preproccesor and seen by a yacc parser for a C grammar. + */ +#define And 257 +#define AndAsgn 258 +#define Arrow 259 +#define CharConst 260 +#define Decr 261 +#define DivAsgn 262 +#define Ellipsis 263 +#define TokEqual 264 +#define Geq 265 +#define Identifier 266 +#define Incr 267 +#define LCharConst 268 +#define LShft 269 +#define LShftAsgn 270 +#define LStrLit 271 +#define Leq 272 +#define MinusAsgn 273 +#define ModAsgn 274 +#define MultAsgn 275 +#define Neq 276 +#define Or 277 +#define OrAsgn 278 +#define PlusAsgn 279 +#define RShft 280 +#define RShftAsgn 281 +#define StrLit 282 +#define XorAsgn 283 +#endif /* NoRTT */ +#endif /* TokDotH */ diff --git a/src/rtt/Makefile b/src/rtt/Makefile new file mode 100644 index 0000000..db6445e --- /dev/null +++ b/src/rtt/Makefile @@ -0,0 +1,87 @@ +# Makefile for the Icon run-time translator, rtt, +# which is used to build the Icon run-time system. + +include ../../Makedefs + + +ROBJS = rttparse.o rttmain.o rttlex.o rttsym.o rttnode.o rttout.o rttmisc.o\ + rttdb.o rttinlin.o rttilc.o + +PP_DIR = ../preproc/ +P_DOT_H = $(PP_DIR)preproc.h $(PP_DIR)pproto.h ltoken.h ../h/mproto.h\ + ../h/define.h ../h/config.h ../h/typedefs.h\ + ../h/cstructs.h ../h/cpuconf.h +POBJS = pout.o pchars.o perr.o pmem.o bldtok.o macro.o preproc.o\ + evaluate.o files.o gettok.o pinit.o + +COBJS = ../common/getopt.o ../common/time.o ../common/filepart.o \ + ../common/identify.o ../common/strtbl.o ../common/alloc.o \ + ../common/rtdb.o ../common/munix.o ../common/literals.o + +OBJ = $(ROBJS) $(POBJS) $(COBJS) + + +rtt: $(OBJ) + $(CC) $(LDFLAGS) -o rtt $(OBJ) + cp rtt ../../bin + strip ../../bin/rtt$(EXE) + +library: $(OBJ) + rm -rf rtt.a + ar qc rtt.a $(OBJ) + +$(COBJS): + cd ../common; $(MAKE) + +$(ROBJS): rtt.h rtt1.h rttproto.h $(P_DOT_H) + +rttdb.o: ../h/version.h +rttparse.o : ../h/gsupport.h ../h/config.h ../h/cstructs.h \ + ../h/mproto.h ../h/typedefs.h ../h/cpuconf.h ../h/define.h + +pout.o: $(PP_DIR)pout.c $(P_DOT_H) + $(CC) -c $(CFLAGS) $(PP_DIR)pout.c + +pchars.o: $(PP_DIR)pchars.c $(P_DOT_H) + $(CC) -c $(CFLAGS) $(PP_DIR)pchars.c + +perr.o: $(PP_DIR)perr.c $(P_DOT_H) + $(CC) -c $(CFLAGS) $(PP_DIR)perr.c + +pmem.o: $(PP_DIR)pmem.c $(P_DOT_H) + $(CC) -c $(CFLAGS) $(PP_DIR)pmem.c + +bldtok.o: $(PP_DIR)bldtok.c $(P_DOT_H) + $(CC) -c $(CFLAGS) $(PP_DIR)bldtok.c + +macro.o: $(PP_DIR)macro.c $(P_DOT_H) + $(CC) -c $(CFLAGS) $(PP_DIR)macro.c + +preproc.o: $(PP_DIR)preproc.c $(P_DOT_H) + $(CC) -c $(CFLAGS) $(PP_DIR)preproc.c + +evaluate.o: $(PP_DIR)evaluate.c $(P_DOT_H) + $(CC) -c $(CFLAGS) $(PP_DIR)evaluate.c + +files.o: $(PP_DIR)files.c $(P_DOT_H) + $(CC) -c $(CFLAGS) $(PP_DIR)files.c + +gettok.o: $(PP_DIR)gettok.c $(P_DOT_H) + $(CC) -c $(CFLAGS) $(PP_DIR)gettok.c + +pinit.o: $(PP_DIR)pinit.c $(P_DOT_H) + $(CC) -c $(CFLAGS) $(PP_DIR)pinit.c + +# +# The following entry is commented out because it is not normally +# necessary to recreate rttparse.c and ltoken.h unless the grammar +# in rttgram.y for the run-time langauge is changed. Recreating these +# files is not normally a part of the installation process. Note that +# on some systems, yacc may not have large enough internal tables to +# translate this grammar. +# +#rttparse.c ltoken.h: rttgram.y +# yacc -d rttgram.y +# fgrep -v -x "extern char *malloc(), *realloc();" y.tab.c > rttparse.c +# rm y.tab.c +# mv y.tab.h ltoken.h diff --git a/src/rtt/ltoken.h b/src/rtt/ltoken.h new file mode 100644 index 0000000..d426fcf --- /dev/null +++ b/src/rtt/ltoken.h @@ -0,0 +1,117 @@ + +typedef union { + struct token *t; + struct node *n; + long i; + } YYSTYPE; +extern YYSTYPE yylval; +# define Identifier 257 +# define StrLit 258 +# define LStrLit 259 +# define FltConst 260 +# define DblConst 261 +# define LDblConst 262 +# define CharConst 263 +# define LCharConst 264 +# define IntConst 265 +# define UIntConst 266 +# define LIntConst 267 +# define ULIntConst 268 +# define Arrow 269 +# define Incr 270 +# define Decr 271 +# define LShft 272 +# define RShft 273 +# define Leq 274 +# define Geq 275 +# define TokEqual 276 +# define Neq 277 +# define And 278 +# define Or 279 +# define MultAsgn 280 +# define DivAsgn 281 +# define ModAsgn 282 +# define PlusAsgn 283 +# define MinusAsgn 284 +# define LShftAsgn 285 +# define RShftAsgn 286 +# define AndAsgn 287 +# define XorAsgn 288 +# define OrAsgn 289 +# define Sizeof 290 +# define Intersect 291 +# define OpSym 292 +# define Typedef 293 +# define Extern 294 +# define Static 295 +# define Auto 296 +# define TokRegister 297 +# define Tended 298 +# define TokChar 299 +# define TokShort 300 +# define Int 301 +# define TokLong 302 +# define Signed 303 +# define Unsigned 304 +# define Float 305 +# define Doubl 306 +# define Const 307 +# define Volatile 308 +# define Void 309 +# define TypeDefName 310 +# define Struct 311 +# define Union 312 +# define TokEnum 313 +# define Ellipsis 314 +# define Case 315 +# define Default 316 +# define If 317 +# define Else 318 +# define Switch 319 +# define While 320 +# define Do 321 +# define For 322 +# define Goto 323 +# define Continue 324 +# define Break 325 +# define Return 326 +# define Runerr 327 +# define Is 328 +# define Cnv 329 +# define Def 330 +# define Exact 331 +# define Empty_type 332 +# define IconType 333 +# define Component 334 +# define Variable 335 +# define Any_value 336 +# define Named_var 337 +# define Struct_var 338 +# define C_Integer 339 +# define Arith_case 340 +# define C_Double 341 +# define C_String 342 +# define Tmp_string 343 +# define Tmp_cset 344 +# define Body 345 +# define End 346 +# define TokFunction 347 +# define Keyword 348 +# define Operator 349 +# define Underef 350 +# define Declare 351 +# define Suspend 352 +# define Fail 353 +# define Inline 354 +# define Abstract 355 +# define Store 356 +# define TokType 357 +# define New 358 +# define All_fields 359 +# define Then 360 +# define Type_case 361 +# define Of 362 +# define Len_case 363 +# define Constant 364 +# define Errorfail 365 +# define IfStmt 366 diff --git a/src/rtt/rtt.h b/src/rtt/rtt.h new file mode 100644 index 0000000..78ac812 --- /dev/null +++ b/src/rtt/rtt.h @@ -0,0 +1,2 @@ +#include "ltoken.h" +#include "rtt1.h" diff --git a/src/rtt/rtt1.h b/src/rtt/rtt1.h new file mode 100644 index 0000000..76779c7 --- /dev/null +++ b/src/rtt/rtt1.h @@ -0,0 +1,187 @@ +#include "../preproc/preproc.h" +#include "../preproc/pproto.h" + +#define IndentInc 3 +#define MaxCol 80 + +#define Max(x,y) ((x)>(y)?(x):(y)) + +/* + * cfile is used to create a list of cfiles created from a source file. + */ +struct cfile { + char *name; + struct cfile *next; + }; + +/* + * srcfile is an entry of dependants of a source file. + */ +struct srcfile { + char *name; + struct cfile *dependents; + struct srcfile *next; + }; + +#define ForceNl() nl = 1; +extern int nl; /* flag: a new-line is needed in the output */ + +/* + * The lexical analyzer recognizes 3 states. Operators are treated differently + * in each state. + */ +#define DfltLex 0 /* Covers most input. */ +#define OpHead 1 /* In head of an operator definition. */ +#define TypeComp 2 /* In abstract type computation */ + +extern int lex_state; /* state of operator recognition */ +extern char *compiler_def; /* #define for COMPILER */ +extern FILE *out_file; /* output file */ +extern int def_fnd; /* C input defines something concrete */ +extern char *inclname; /* include file to be included by C compiler */ +extern int iconx_flg; /* flag: indicate that iconx style code is needed */ +extern int enable_out; /* enable output of C code */ +extern char *largeints; /* "Largeints" or "NoLargeInts" */ + +/* + * The symbol table is used by the lexical analyser to decide whether an + * identifier is an ordinary identifier, a typedef name, or a reserved + * word. It is used by the parse tree builder to decide whether an + * identifier is an ordinary C variable, a tended variable, a parameter + * to a run-time routine, or the special variable "result". + */ +struct sym_entry { + int tok_id; /* Ident, TokType, or identification of reserved word */ + char *image; /* image of symbol */ + int id_type; /* OtherDcl, TndDesc, TndStr, TndBlk, Label, RtParm, + DrfPrm, RsltLoc */ + union { + struct { /* RtParm: */ + int param_num; /* parameter number */ + int cur_loc; /* PrmTend, PrmCStr, PrmInt, or PrmDbl */ + int non_tend; /* non-tended locations used */ + int parm_mod; /* something may have modified it */ + struct sym_entry *next; + } param_info; + struct { /* TndDesc, TndStr, TndBlk: */ + struct node *init; /* initial value from declaration */ + char *blk_name; /* TndBlk: struct name of block */ + struct sym_entry *next; + } tnd_var; + struct { /* OtherDcl from "declare {...}": */ + struct node *tqual; /* storage class, type qualifier list */ + struct node *dcltor; /* declarator */ + struct node *init; /* initial value from declaration */ + struct sym_entry *next; + } declare_var; + int typ_indx; /* index into arrays of type information */ + word lbl_num; /* label number used in in-line code */ + int referenced; /* RsltLoc: is referenced */ + } u; + int t_indx; /* index into tended array */ + int il_indx; /* index used in in-line code */ + int nest_lvl; /* 0 - reserved word, 1 - global, >= 2 - local */ + int may_mod; /* may be modified in particular piece of code */ + int ref_cnt; + struct sym_entry *next; + }; + +/* + * Path-specific parameter information must be saved and merged for + * branching and joining of paths. + */ +struct parminfo { + int cur_loc; + int parm_mod; + }; + +/* + * A list is maintained of information needed to initialize tended descriptors. + */ +struct init_tend { + int t_indx; /* index into tended array */ + int init_typ; /* TndDesc, TndStr, TndBlk */ + struct node *init; /* initial value from declaration */ + int nest_lvl; /* level of nesting of current use of tended slot */ + int in_use; /* tended slot is being used in current scope */ + struct init_tend *next; + }; + + +extern int op_type; /* Function, Keyword, Operator, or OrdFunc */ +extern char lc_letter; /* f = function, o = operator, k = keyword */ +extern char uc_letter; /* F = function, O = operator, K = keyword */ +extern char prfx1; /* 1st char of unique prefix for operation */ +extern char prfx2; /* 2nd char of unique prefix for operation */ +extern char *fname; /* current source file name */ +extern int line; /* current source line number */ +extern struct implement *cur_impl; /* data base entry for current operator */ +extern struct token *comment; /* descriptive comment for current oper */ +extern int n_tmp_str; /* total number of string buffers needed */ +extern int n_tmp_cset; /* total number of cset buffers needed */ +extern int nxt_sbuf; /* index of next string buffer */ +extern int nxt_cbuf; /* index of next cset buffer */ +extern struct sym_entry *params; /* current list of parameters */ +extern struct sym_entry *decl_lst; /* declarations from "declare {...}" */ +extern struct init_tend *tend_lst; /* list of allocated tended slots */ +extern char *str_rslt; /* string "result" in string table */ +extern word lbl_num; /* next unused label number */ +extern struct sym_entry *v_len; /* symbol entry for size of varargs */ +extern int il_indx; /* next index into data base symbol table */ + +/* + * lvl_entry keeps track of what is happening at a level of nested declarations. + */ +struct lvl_entry { + int nest_lvl; + int kind_dcl; /* IsTypedef, TndDesc, TndStr, TndBlk, or OtherDcl */ + char *blk_name; /* for TndBlk, the struct name of the block */ + int parms_done; /* level consists of parameter list which is complete */ + struct sym_entry *tended; /* symbol table entries for tended variables */ + struct lvl_entry *next; + }; + +extern struct lvl_entry *dcl_stk; /* stack of declaration contexts */ + +extern int fnc_ret; /* RetInt, RetDbl, RetNoVal, or RetSig for current func */ + +#define NoAbstr -1001 /* no abstract return statement has been encountered */ +#define SomeType -1002 /* assume returned value is consistent with abstr ret */ +extern int abs_ret; /* type from abstract return statement */ + +/* + * Definitions for use in parse tree nodes. + */ + +#define PrimryNd 1 /* simply a token */ +#define PrefxNd 2 /* a prefix expression */ +#define PstfxNd 3 /* a postfix expression */ +#define BinryNd 4 /* a binary expression (not necessarily infix) */ +#define TrnryNd 5 /* an expression with 3 subexpressions */ +#define QuadNd 6 /* an expression with 4 subexpressions */ +#define LstNd 7 /* list of declaration parts */ +#define CommaNd 8 /* arg lst, declarator lst, or init lst, not comma op */ +#define StrDclNd 9 /* structure field declaration */ +#define PreSpcNd 10 /* prefix expression that needs a space after it */ +#define ConCatNd 11 /* two ajacent pieces of code with no other syntax */ +#define SymNd 12 /* a symbol (identifier) node */ +#define ExactCnv 13 /* (exact)integer or (exact)C_integer conversion */ +#define CompNd 14 /* compound statement */ +#define AbstrNd 15 /* abstract type computation */ +#define IcnTypNd 16 /* name of an Icon type */ + +#define NewNode(size) (struct node *)alloc(\ + sizeof(struct node) + (size-1) * sizeof(union field)) + +union field { + struct node *child; + struct sym_entry *sym; /* used with SymNd & CompNd*/ + }; + +struct node { + int nd_id; + struct token *tok; + union field u[1]; /* actual size varies with node type */ + }; + +#include "rttproto.h" diff --git a/src/rtt/rttdb.c b/src/rtt/rttdb.c new file mode 100644 index 0000000..22368fe --- /dev/null +++ b/src/rtt/rttdb.c @@ -0,0 +1,1440 @@ +/* + * rttdb.c - routines to read, manipulate, and write the data base of + * information about run-time routines. + */ + +#include "rtt.h" +#include "../h/version.h" + +#define DHSize 47 +#define MaxLine 80 + +/* + * prototypes for static functions. + */ +static void max_pre (struct implement **tbl, char *pre); +static int name_cmp (char *p1, char *p2); +static int op_cmp (char *p1, char *p2); +static void prt_dpnd (FILE *db); +static void prt_impls (FILE *db, char *sect, struct implement **tbl, + int num, struct implement **sort_ary, int (*com)()); +static int prt_c_fl (FILE *db, struct cfile *clst, int line_left); +static int put_case (FILE *db, struct il_code *il); +static void put_ilc (FILE *db, struct il_c *ilc); +static void put_inlin (FILE *db, struct il_code *il); +static void put_ret (FILE *db, struct il_c *ilc); +static void put_typcd (FILE *db, int typcd); +static void put_var (FILE *db, int code, struct il_c *ilc); +static void ret_flag (FILE *db, int flag, int may_fthru); +static int set_impl (struct token *name, struct implement **tbl, + int num_impl, char *pre); +static void set_prms (struct implement *ptr); +static int src_cmp (char *p1, char *p2); + +static struct implement *bhash[IHSize]; /* hash area for built-in func table */ +static struct implement *ohash[IHSize]; /* hash area for operator table */ +static struct implement *khash[IHSize]; /* hash area for keyword table */ + +static struct srcfile *dhash[DHSize]; /* hash area for file dependencies */ + +static int num_fnc; /* number of function in data base */ +static int num_op = 0; /* number of operators in data base */ +static int num_key; /* number of keywords in data base */ +static int num_src = 0; /* number of source files in dependencies */ + +static char fnc_pre[2]; /* next prefix available for functions */ +static char op_pre[2]; /* next prefix available for operators */ +static char key_pre[2]; /* next prefix available for keywords */ + +static long min_rs; /* min result sequence of current operation */ +static long max_rs; /* max result sequence of current operation */ +static int rsm_rs; /* '+' at end of result sequencce of cur. oper. */ + +static int newdb = 0; /* flag: this is a new data base */ +struct token *comment; /* comment associated with current operation */ +struct implement *cur_impl; /* data base entry for current operation */ + +/* + * loaddb - load data base. + */ +void loaddb(dbname) +char *dbname; + { + char *op; + struct implement *ip; + unsigned hashval; + int i; + char *srcname; + char *c_name; + struct srcfile *sfile; + + + /* + * Initialize internal data base. + */ + for (i = 0; i < IHSize; i++) { + bhash[i] = NULL; /* built-in function table */ + ohash[i] = NULL; /* operator table */ + khash[i] = NULL; /* keyword table */ + } + for (i = 0; i < DHSize; i++) + dhash[i] = NULL; /* dependency table */ + + /* + * Determine if this is a new data base or an existing one. + */ + if (iconx_flg || !db_open(dbname, &largeints)) + newdb = 1; + else { + + /* + * Read information about built-in functions. + */ + num_fnc = db_tbl("functions", bhash); + + /* + * Read information about operators. + */ + db_chstr("", "operators"); /* verify and skip "operators" */ + + while ((op = db_string()) != NULL) { + /* + * Read header information for the operator. + */ + if ((ip = db_impl('O')) == NULL) + db_err2(1, "no implementation information for operator", op); + ip->op = op; + + /* + * Read the descriptive comment and in-line code for the operator, + * then put the entry in the hash table. + */ + db_code(ip); + hashval = (int)IHasher(op); + ip->blink = ohash[hashval]; + ohash[hashval] = ip; + db_chstr("", "end"); /* verify and skip "end" */ + ++num_op; + } + db_chstr("", "endsect"); /* verify and skip "endsect" */ + + /* + * Read information about keywords. + */ + num_key = db_tbl("keywords", khash); + + /* + * Read C file/source dependency information. + */ + db_chstr("", "dependencies"); /* verify and skip "dependencies" */ + + while ((srcname = db_string()) != NULL) { + sfile = src_lkup(srcname); + while ((c_name = db_string()) != NULL) + add_dpnd(sfile, c_name); + db_chstr("", "end"); /* verify and skip "end" */ + } + db_chstr("", "endsect"); /* verify and skip "endsect" */ + + db_close(); + } + + /* + * Determine the next available operation prefixes by finding the + * maximum prefixes currently in use. + */ + max_pre(bhash, fnc_pre); + max_pre(ohash, op_pre); + max_pre(khash, key_pre); + } + +/* + * max_pre - find the maximum prefix in an implemetation table and set the + * prefix array to the next value. + */ +static void max_pre(tbl, pre) +struct implement **tbl; +char *pre; + { + register struct implement *ptr; + unsigned hashval; + int empty = 1; + char dmy_pre[2]; + + pre[0] = '0'; + pre[1] = '0'; + for (hashval = 0; hashval < IHSize; ++hashval) + for (ptr = tbl[hashval]; ptr != NULL; ptr = ptr->blink) { + empty = 0; + /* + * Determine if this prefix is larger than any found so far. + */ + if (cmp_pre(ptr->prefix, pre) > 0) { + pre[0] = ptr->prefix[0]; + pre[1] = ptr->prefix[1]; + } + } + if (!empty) + nxt_pre(dmy_pre, pre, 2); + } + + +/* + * src_lkup - return pointer to dependency information for the given + * source file. + */ +struct srcfile *src_lkup(srcname) +char *srcname; + { + unsigned hashval; + struct srcfile *sfile; + + /* + * See if the source file is already in the dependancy section of + * the data base. + */ + hashval = (unsigned int)(unsigned long)srcname % DHSize; + for (sfile = dhash[hashval]; sfile != NULL && sfile->name != srcname; + sfile = sfile->next) + ; + + /* + * If an entry for the source file was not found, create one. + */ + if (sfile == NULL) { + sfile = NewStruct(srcfile); + sfile->name = srcname; + sfile->dependents = NULL; + sfile->next = dhash[hashval]; + dhash[hashval] = sfile; + ++num_src; + } + return sfile; + } + +/* + * add_dpnd - add the given source/dependency relation to the dependency + * table. + */ +void add_dpnd(sfile, c_name) +struct srcfile *sfile; +char *c_name; + { + struct cfile *cf; + + cf = NewStruct(cfile); + cf->name = c_name; + cf->next = sfile->dependents; + sfile->dependents = cf; + } + +/* + * clr_dpnd - delete all dependencies for the given source file. + */ +void clr_dpnd(srcname) +char *srcname; + { + src_lkup(srcname)->dependents = NULL; + } + +/* + * dumpdb - write the updated data base. + */ +void dumpdb(dbname) +char *dbname; + { + #ifdef Rttx + fprintf(stdout, + "rtt was compiled to only support the intepreter, use -x\n"); + exit(EXIT_FAILURE); + #else /* Rttx */ + FILE *db; + struct implement **sort_ary; + int ary_sz; + int i; + + db = fopen(dbname, "wb"); + if (db == NULL) + err2("cannot open data base for output:", dbname); + if(newdb) + fprintf(stdout, "creating new data base: %s\n", dbname); + + /* + * The data base starts with a version number associated with this + * version of rtt and an indication of whether LargeInts was + * defined during the build. + */ + fprintf(db, "%s %s\n\n", DVersion, largeints); + + fprintf(db, "\ntypes\n\n"); /* start of type code section */ + for (i = 0; i < num_typs; ++i) + fprintf(db, " T%d: %s\n", i, icontypes[i].id); + fprintf(db, "\n$endsect\n\n"); /* end of section for type codes */ + + fprintf(db, "\ncomponents\n\n"); /* start of component code section */ + for (i = 0; i < num_cmpnts; ++i) + fprintf(db, " C%d: %s\n", i, typecompnt[i].id); + fprintf(db, "\n$endsect\n\n"); /* end of section for component codes */ + + /* + * Allocate an array for sorting operation entries. It must be + * large enough to hold functions, operators, or keywords. + */ + ary_sz = Max(num_fnc, num_op); + ary_sz = Max(ary_sz, num_key); + if (ary_sz > 0) + sort_ary = alloc(ary_sz * sizeof(struct implement*)); + else + sort_ary = NULL; + + /* + * Sort and print to the data base the enties for each of the + * three operation sections. + */ + prt_impls(db, "functions", bhash, num_fnc, sort_ary, name_cmp); + prt_impls(db, "\noperators", ohash, num_op, sort_ary, op_cmp); + prt_impls(db, "\nkeywords", khash, num_key, sort_ary, name_cmp); + if (ary_sz > 0) + free((char *)sort_ary); + + /* + * Print the dependancy information to the data base. + */ + prt_dpnd(db); + if (fclose(db) != 0) + err2("cannot close ", dbname); + #endif /* Rttx */ + } + +#ifndef Rttx +/* + * prt_impl - sort and print to the data base the enties from one + * of the operation tables. + */ +static void prt_impls(db, sect, tbl, num, sort_ary, cmp) +FILE *db; +char *sect; +struct implement **tbl; +int num; +struct implement **sort_ary; +int (*cmp)(); + { + int i; + int j; + unsigned hashval; + struct implement *ip; + + /* + * Each operation section begins with the section name. + */ + fprintf(db, "%s\n\n", sect); + + /* + * Sort the table entries before printing. + */ + if (num > 0) { + i = 0; + for (hashval = 0; hashval < IHSize; ++hashval) + for (ip = tbl[hashval]; ip != NULL; ip = ip->blink) + sort_ary[i++] = ip; + qsort((char *)sort_ary, num, sizeof(struct implement *), cmp); + } + + /* + * Output each entry to the data base. + */ + for (i = 0; i < num; ++i) { + ip = sort_ary[i]; + + /* + * Operators have operator symbols. + */ + if (ip->op != NULL) + fprintf(db, "%s\t", ip->op); + + /* + * Print the operation name, the unique prefix used to generate + * C function names, and the number of parameters to the operation. + */ + fprintf(db, "%s\t%c%c %d(", ip->name, ip->prefix[0], ip->prefix[1], + ip->nargs); + + /* + * For each parameter, write and indication of whether a dereferenced + * value, 'd', and/or and undereferenced value, 'u', is needed. + */ + for (j = 0; j < ip->nargs; ++j) { + if (j > 0) + fprintf(db, ","); + if (ip->arg_flgs[j] & RtParm) + fprintf(db, "u"); + if (ip->arg_flgs[j] & DrfPrm) + fprintf(db, "d"); + } + + /* + * Indicate if the last parameter represents the tail of a + * variable length argument list. + */ + if (ip->nargs > 0 && ip->arg_flgs[ip->nargs - 1] & VarPrm) + fprintf(db, "v"); + fprintf(db, ")\t{"); + + /* + * Print the min and max result sequence length. + */ + if (ip->min_result != NoRsltSeq) { + fprintf(db, "%ld,", ip->min_result); + if (ip->max_result == UnbndSeq) + fprintf(db, "*"); + else + fprintf(db, "%ld", ip->max_result); + if (ip->resume) + fprintf(db, "+"); + } + fprintf(db, "} "); + + /* + * Print the return/suspend/fail/fall-through flag and an indication + * of whether the operation explicitly uses the result location + * (as opposed to an implicit use via return or suspend). + */ + ret_flag(db, ip->ret_flag, 0); + if (ip->use_rslt) + fprintf(db, "t "); + else + fprintf(db, "f "); + + /* + * Print the descriptive comment associated with the operation. + */ + fprintf(db, "\n\"%s\"\n", ip->comment); + + /* + * Print information about tended declarations from the declare + * statement. The number of tended variables is printed followed + * by an entry for each variable. Each entry consists of the + * type of the declaration + * + * struct descrip -> desc + * char * -> str + * struct b_xxx * -> blkptr b_xxx + * union block * -> blkptr * + * + * followed by the C code for the initializer (nil indicates none). + */ + fprintf(db, "%d ", ip->ntnds); + for (j = 0; j < ip->ntnds; ++j) { + switch (ip->tnds[j].var_type) { + case TndDesc: + fprintf(db, "desc "); + break; + case TndStr: + fprintf(db, "str "); + break; + case TndBlk: + fprintf(db, "blkptr "); + if (ip->tnds[j].blk_name == NULL) + fprintf(db, "* "); + else + fprintf(db, "%s ", ip->tnds[j].blk_name); + break; + } + put_ilc(db, ip->tnds[j].init); + } + + /* + * Print information about non-tended declarations from the declare + * statement. The number of variables is printed followed by an + * entry for each variable. Each entry consists of the variable + * name followed by the complete C code for the declaration. + */ + fprintf(db, "\n%d ", ip->nvars); + for (j = 0; j < ip->nvars; ++j) { + fprintf(db, "%s ", ip->vars[j].name); + put_ilc(db, ip->vars[j].dcl); + } + fprintf(db, "\n"); + + /* + * Output the "executable" code (includes abstract code) for the + * operation. + */ + put_inlin(db, ip->in_line); + fprintf(db, "\n$end\n\n"); /* end of operation entry */ + } + fprintf(db, "$endsect\n\n"); /* end of section for operation type */ + } + +/* + * put_inlin - put in-line code into the data base file. This is the + * code used by iconc to perform type infernence for the operation + * and to generate a tailored version of the operation. + */ +static void put_inlin(db, il) +FILE *db; +struct il_code *il; + { + int i; + int num_cases; + int indx; + + /* + * RTL statements are handled by this function. Other functions + * are called for C code. + */ + if (il == NULL) { + fprintf(db, "nil "); + return; + } + + switch (il->il_type) { + case IL_Const: + /* + * Constant keyword. + */ + fprintf(db, "const "); + put_typcd(db, il->u[0].n); /* type code */ + fputs(il->u[1].s, db); fputc(' ', db); /* literal */ + break; + case IL_If1: + /* + * if-then statment. + */ + fprintf(db, "if1 "); + put_inlin(db, il->u[0].fld); /* condition */ + fprintf(db, "\n"); + put_inlin(db, il->u[1].fld); /* then clause */ + break; + case IL_If2: + /* + * if-then-else statment. + */ + fprintf(db, "if2 "); + put_inlin(db, il->u[0].fld); /* condition */ + fprintf(db, "\n"); + put_inlin(db, il->u[1].fld); /* then clause */ + fprintf(db, "\n"); + put_inlin(db, il->u[2].fld); /* else clause */ + break; + case IL_Tcase1: + /* + * type_case statement with no default clause. + */ + fprintf(db, "tcase1 "); + put_case(db, il); + break; + case IL_Tcase2: + /* + * type_case statement with a default clause. + */ + fprintf(db, "tcase2 "); + indx = put_case(db, il); + fprintf(db, "\n"); + put_inlin(db, il->u[indx].fld); /* default */ + break; + case IL_Lcase: + /* + * len_case statement. + */ + fprintf(db, "lcase "); + num_cases = il->u[0].n; + fprintf(db, "%d ", num_cases); + indx = 1; + for (i = 0; i < num_cases; ++i) { + fprintf(db, "\n%d ", il->u[indx++].n); /* selection number */ + put_inlin(db, il->u[indx++].fld); /* action */ + } + fprintf(db, "\n"); + put_inlin(db, il->u[indx].fld); /* default */ + break; + case IL_Acase: + /* + * arith_case statement. + */ + fprintf(db, "acase "); + put_inlin(db, il->u[0].fld); /* first variable */ + put_inlin(db, il->u[1].fld); /* second variable */ + fprintf(db, "\n"); + put_inlin(db, il->u[2].fld); /* C_integer action */ + fprintf(db, "\n"); + put_inlin(db, il->u[3].fld); /* integer action */ + fprintf(db, "\n"); + put_inlin(db, il->u[4].fld); /* C_double action */ + break; + case IL_Err1: + /* + * runerr with no value argument. + */ + fprintf(db, "runerr1 "); + fprintf(db, "%d ", il->u[0].n); /* error number */ + break; + case IL_Err2: + /* + * runerr with a value argument. + */ + fprintf(db, "runerr2 "); + fprintf(db, "%d ", il->u[0].n); /* error number */ + put_inlin(db, il->u[1].fld); /* variable */ + break; + case IL_Lst: + /* + * "glue" to string statements together. + */ + fprintf(db, "lst "); + put_inlin(db, il->u[0].fld); + fprintf(db, "\n"); + put_inlin(db, il->u[1].fld); + break; + case IL_Bang: + /* + * ! operator from type checking. + */ + fprintf(db, "! "); + put_inlin(db, il->u[0].fld); + break; + case IL_And: + /* + * && operator from type checking. + */ + fprintf(db, "&& "); + put_inlin(db, il->u[0].fld); + put_inlin(db, il->u[1].fld); + break; + case IL_Cnv1: + /* + * cnv:() + */ + fprintf(db, "cnv1 "); + put_typcd(db, il->u[0].n); /* type code */ + put_inlin(db, il->u[1].fld); /* source */ + break; + case IL_Cnv2: + /* + * cnv:(,) + */ + fprintf(db, "cnv2 "); + put_typcd(db, il->u[0].n); /* type code */ + put_inlin(db, il->u[1].fld); /* source */ + put_ilc(db, il->u[2].c_cd); /* destination */ + break; + case IL_Def1: + /* + * def:(,) + */ + fprintf(db, "def1 "); + put_typcd(db, il->u[0].n); /* type code */ + put_inlin(db, il->u[1].fld); /* source */ + put_ilc(db, il->u[2].c_cd); /* default value */ + break; + case IL_Def2: + /* + * def:(,,) + */ + fprintf(db, "def2 "); + put_typcd(db, il->u[0].n); /* type code */ + put_inlin(db, il->u[1].fld); /* source */ + put_ilc(db, il->u[2].c_cd); /* default value */ + put_ilc(db, il->u[3].c_cd); /* destination */ + break; + case IL_Is: + /* + * is:() + */ + fprintf(db, "is "); + put_typcd(db, il->u[0].n); /* type code */ + put_inlin(db, il->u[1].fld); /* variable */ + break; + case IL_Var: + /* + * A variable. + */ + fprintf(db, "%d ", il->u[0].n); /* symbol table index */ + break; + case IL_Subscr: + /* + * A subscripted variable. + */ + fprintf(db, "[ "); + fprintf(db, "%d ", il->u[0].n); /* symbol table index */ + fprintf(db, "%d ", il->u[1].n); /* subscripting index */ + break; + case IL_Block: + /* + * A block of in-line code. + */ + fprintf(db, "block "); + if (il->u[0].n) + fprintf(db, "t "); /* execution can fall through */ + else + fprintf(db, "_ "); /* execution cannot fall through */ + /* + * Output a symbol table of tended variables. + */ + fprintf(db, "%d ", il->u[1].n); /* number of local tended */ + for (i = 2; i - 2 < il->u[1].n; ++i) + switch (il->u[i].n) { + case TndDesc: + fprintf(db, "desc "); + break; + case TndStr: + fprintf(db, "str "); + break; + case TndBlk: + fprintf(db, "blkptr "); + break; + } + put_ilc(db, il->u[i].c_cd); /* body of block */ + break; + case IL_Call: + /* + * A call to a body function. + */ + fprintf(db, "call "); + + /* + * Each body function has a 3rd prefix character to distingish + * it from other functions for the operation. + */ + fprintf(db, "%c ", (char)il->u[1].n); + + /* + * A body function that would only return one possible signal + * need return none. In which case, it can directly return a + * C integer or double directly rather than using a result + * descriptor location. Indicate what it does. + */ + switch (il->u[2].n) { + case RetInt: + fprintf(db, "i "); /* directly return integer */ + break; + case RetDbl: + fprintf(db, "d "); /* directly return double */ + break; + case RetNoVal: + fprintf(db, "n "); /* return nothing directly */ + break; + case RetSig: + fprintf(db, "s "); /* return a signal */ + break; + } + + /* + * Output the return/suspend/fail/fall-through flag. + */ + ret_flag(db, il->u[3].n, 1); + + /* + * Indicate whether the body function expects to have + * an explicit result location passed to it. + */ + if (il->u[4].n) + fprintf(db, "t "); + else + fprintf(db, "f "); + + fprintf(db, "%d ", il->u[5].n); /* num string bufs */ + fprintf(db, "%d ", il->u[6].n); /* num cset bufs */ + i = il->u[7].n; + fprintf(db, "%d ", i); /* num args */ + indx = 8; + /* + * output prototype paramater declarations and actual arguments. + */ + i *= 2; + while (i--) + put_ilc(db, il->u[indx++].c_cd); + break; + case IL_Abstr: + /* + * Abstract type computation. + */ + fprintf(db, "abstr "); + put_inlin(db, il->u[0].fld); /* side effects */ + put_inlin(db, il->u[1].fld); /* return type */ + break; + case IL_VarTyp: + /* + * type() + */ + fprintf(db, "vartyp "); + put_inlin(db, il->u[0].fld); /* variable */ + break; + case IL_Store: + /* + * store[] + */ + fprintf(db, "store "); + put_inlin(db, il->u[0].fld); /* type to be "dereferenced "*/ + break; + case IL_Compnt: + /* + * . + */ + fprintf(db, ". "); + put_inlin(db, il->u[0].fld); /* type */ + if (il->u[1].n == CM_Fields) + fprintf(db, "f "); /* special case record fields */ + else + fprintf(db, "C%d ", (int)il->u[1].n); /* component table index */ + break; + case IL_TpAsgn: + /* + * store[] = + */ + fprintf(db, "= "); + put_inlin(db, il->u[0].fld); /* variable type */ + put_inlin(db, il->u[1].fld); /* value type */ + break; + case IL_Union: + /* + * ++ + */ + fprintf(db, "++ "); + put_inlin(db, il->u[0].fld); + put_inlin(db, il->u[1].fld); + break; + case IL_Inter: + /* + * ** + */ + fprintf(db, "** "); + put_inlin(db, il->u[0].fld); + put_inlin(db, il->u[1].fld); + break; + case IL_New: + /* + * new ( , ...) + */ + fprintf(db, "new "); + put_typcd(db, il->u[0].n); /* type code */ + i = il->u[1].n; + fprintf(db, "%d ", i); /* num args */ + indx = 2; + while (i--) + put_inlin(db, il->u[indx++].fld); + break; + case IL_IcnTyp: + /* + * + */ + fprintf(db, "typ "); + put_typcd(db, il->u[0].n); /* type code */ + break; + } + } + +/* + * put_case - put the cases of a type_case statement into the data base file. + */ +static int put_case(db, il) +FILE *db; +struct il_code *il; + { + int *typ_vect; + int i, j; + int num_cases; + int num_types; + int indx; + + put_inlin(db, il->u[0].fld); /* expression being checked */ + num_cases = il->u[1].n; /* number of cases */ + fprintf(db, "%d ", num_cases); + indx = 2; + for (i = 0; i < num_cases; ++i) { + num_types = il->u[indx++].n; /* number of types in case */ + fprintf(db, "\n%d ", num_types); + typ_vect = il->u[indx++].vect; /* vector of type codes */ + for (j = 0; j < num_types; ++j) + put_typcd(db, typ_vect[j]); /* type code */ + put_inlin(db, il->u[indx++].fld); /* action */ + } + return indx; + } + +/* + * put_typcd - convert a numeric type code into an alpha type code and + * put it in the data base file. + */ +static void put_typcd(db, typcd) +FILE *db; +int typcd; + { + if (typcd >= 0) + fprintf(db, "T%d ", typcd); + else { + switch (typcd) { + case TypAny: + fprintf(db, "a "); /* any_value */ + break; + case TypEmpty: + fprintf(db, "e "); /* empty_type */ + break; + case TypVar: + fprintf(db, "v "); /* variable */ + break; + case TypCInt: + fprintf(db, "ci "); /* C_integer */ + break; + case TypCDbl: + fprintf(db, "cd "); /* C_double */ + break; + case TypCStr: + fprintf(db, "cs "); /* C_string */ + break; + case TypEInt: + fprintf(db, "ei "); /* (exact)integer) */ + break; + case TypECInt: + fprintf(db, "eci "); /* (exact)C_integer */ + break; + case TypTStr: + fprintf(db, "ts "); /* tmp_string */ + break; + case TypTCset: + fprintf(db, "tc "); /* tmp_cset */ + break; + case RetDesc: + fprintf(db, "d "); /* plain descriptor on return/suspend */ + break; + case RetNVar: + fprintf(db, "nv "); /* named_var */ + break; + case RetSVar: + fprintf(db, "sv "); /* struct_var */ + break; + case RetNone: + fprintf(db, "rn "); /* preset result location on return/suspend */ + break; + } + } + } + +/* + * put_ilc - put in-line C code in the data base file. + */ +static void put_ilc(db, ilc) +FILE *db; +struct il_c *ilc; + { + /* + * In-line C code is either "nil" or code bracketed by $c $e. + * The bracketed code consists of text for C code plus special + * constructs starting with $. Control structures have been + * translated into gotos in the form of special constructs + * (note that case statements are not supported in in-line code). + */ + if (ilc == NULL) { + fprintf(db, "nil "); + return; + } + fprintf(db, "$c "); + while (ilc != NULL) { + switch(ilc->il_c_type) { + case ILC_Ref: + put_var(db, 'r', ilc); /* non-modifying reference to variable */ + break; + case ILC_Mod: + put_var(db, 'm', ilc); /* modifying reference to variable */ + break; + case ILC_Tend: + put_var(db, 't', ilc); /* variable declared tended */ + break; + case ILC_SBuf: + fprintf(db, "$sb "); /* string buffer for tmp_string */ + break; + case ILC_CBuf: + fprintf(db, "$cb "); /* cset buffer for tmp_cset */ + break; + case ILC_Ret: + fprintf(db, "$ret "); /* return statement */ + put_ret(db, ilc); + break; + case ILC_Susp: + fprintf(db, "$susp "); /* suspend statement */ + put_ret(db, ilc); + break; + case ILC_Fail: + fprintf(db, "$fail "); /* fail statement */ + break; + case ILC_EFail: + fprintf(db, "$efail "); /* errorfail statement */ + break; + case ILC_Goto: + fprintf(db, "$goto %d ", ilc->n); /* goto label */ + break; + case ILC_CGto: + fprintf(db, "$cgoto "); /* conditional goto */ + put_ilc(db, ilc->code[0]); /* condition (with $c $e) */ + fprintf(db, "%d ", ilc->n); /* label */ + break; + case ILC_Lbl: + fprintf(db, "$lbl %d ", ilc->n); /* label */ + break; + case ILC_LBrc: + fprintf(db, "${ "); /* start of C block with dcls */ + break; + case ILC_RBrc: + fprintf(db, "$} "); /* end of C block with dcls */ + break; + case ILC_Str: + fprintf(db, "%s", ilc->s); /* C code as plain text */ + break; + } + ilc = ilc->next; + } + fprintf(db, " $e "); + } + +/* + * put_var - output in-line C code for a variable. + */ +static void put_var(db, code, ilc) +FILE *db; +int code; +struct il_c *ilc; + { + fprintf(db, "$%c", code); /* 'r': non-mod ref, 'm': mod ref, 't': tended */ + if (ilc->s != NULL) + fprintf(db, "%s", ilc->s); /* access into descriptor */ + if (ilc->n == RsltIndx) + fprintf(db, "r "); /* this is "result" */ + else + fprintf(db, "%d ", ilc->n); /* offset into a symbol table */ + } + +/* + * ret_flag - put a return/suspend/fail/fall-through flag in the data base + * file. + */ +static void ret_flag(db, flag, may_fthru) +FILE *db; +int flag; +int may_fthru; + { + if (flag & DoesFail) + fprintf(db, "f"); /* can fail */ + else + fprintf(db, "_"); /* cannot fail */ + if (flag & DoesRet) + fprintf(db, "r"); /* can return */ + else + fprintf(db, "_"); /* cannot return */ + if (flag & DoesSusp) + fprintf(db, "s"); /* can suspend */ + else + fprintf(db, "_"); /* cannot suspend */ + if (flag & DoesEFail) + fprintf(db, "e"); /* can do error conversion */ + else + fprintf(db, "_"); /* cannot do error conversion */ + if (may_fthru) /* body functions only: */ + if (flag & DoesFThru) + fprintf(db, "t"); /* can fall through */ + else + fprintf(db, "_"); /* cannot fall through */ + fprintf(db, " "); + } + +/* + * put_ret - put the body of a return/suspend statement in the data base. + */ +static void put_ret(db, ilc) +FILE *db; +struct il_c *ilc; + { + int i; + + /* + * Output the type of descriptor constructor on the return/suspend, + * then output the the number of arguments to the constructor, and + * the arguments themselves. + */ + put_typcd(db, ilc->n); + for (i = 0; i < 3 && ilc->code[i] != NULL; ++i) + ; + fprintf(db, "%d ", i); + for (i = 0; i < 3 && ilc->code[i] != NULL; ++i) + put_ilc(db, ilc->code[i]); + } + +/* + * name_cmp - compare implementation structs by name; function used as + * an argument to qsort(). + */ +static int name_cmp(p1, p2) +char *p1; +char *p2; + { + register struct implement *ip1; + register struct implement *ip2; + + ip1 = *(struct implement **)p1; + ip2 = *(struct implement **)p2; + return strcmp(ip1->name, ip2->name); + } + +/* + * op_cmp - compare implementation structs by operator and number of args; + * function used as an argument to qsort(). + */ +static int op_cmp(p1, p2) +char *p1; +char *p2; + { + register int cmp; + register struct implement *ip1; + register struct implement *ip2; + + ip1 = *(struct implement **)p1; + ip2 = *(struct implement **)p2; + + cmp = strcmp(ip1->op, ip2->op); + if (cmp == 0) + return ip1->nargs - ip2->nargs; + else + return cmp; + } + +/* + * prt_dpnd - print dependency information to the data base. + */ +static void prt_dpnd(db) +FILE *db; + { + struct srcfile **sort_ary; + struct srcfile *sfile; + unsigned hashval; + int line_left; + int num; + int i; + + fprintf(db, "\ndependencies\n\n"); /* start of dependency section */ + + /* + * sort the dependency information by source file name. + */ + num = 0; + if (num_src > 0) { + sort_ary = alloc(num_src * sizeof(struct srcfile *)); + for (hashval = 0; hashval < DHSize; ++hashval) + for (sfile = dhash[hashval]; sfile != NULL; sfile = sfile->next) + sort_ary[num++] = sfile; + qsort((char *)sort_ary, num, sizeof(struct srcfile *), + (int (*)())src_cmp); + } + + /* + * For each source file with dependents, output the source file + * name followed by the list of dependent files. The list is + * terminated with "end". + */ + for (i = 0; i < num; ++i) { + sfile = sort_ary[i]; + if (sfile->dependents != NULL) { + fprintf(db, "%-12s ", sfile->name); + line_left = prt_c_fl(db, sfile->dependents, MaxLine - 14); + if (line_left - 4 < 0) + fprintf(db, "\n "); + fprintf(db, "$end\n"); + } + } + fprintf(db, "\n$endsect\n"); /* end of dependency section */ + if (num_src > 0) + free((char *)sort_ary); + } + +/* + * src_cmp - compare srcfile structs; function used as an argument to qsort(). + */ +static int src_cmp(p1, p2) +char *p1; +char *p2; + { + register struct srcfile *sp1; + register struct srcfile *sp2; + + sp1 = *(struct srcfile **)p1; + sp2 = *(struct srcfile **)p2; + return strcmp(sp1->name, sp2->name); + } + +/* + * prt_c_fl - print list of C files in reverse order. + */ +static int prt_c_fl(db, clst, line_left) +FILE *db; +struct cfile *clst; +int line_left; + { + int len; + + if (clst == NULL) + return line_left; + line_left = prt_c_fl(db, clst->next, line_left); + + /* + * If this will exceed the line length, print a new-line and some + * leading white space. + */ + len = strlen(clst->name) + 1; + if (line_left - len < 0) { + fprintf(db, "\n "); + line_left = MaxLine - 14; + } + fprintf(db, "%s ", clst->name); + return line_left - len; + } +#endif /* Rttx */ + +/* + * full_lst - print a full list of all files produced by translations + * as represented in the dependencies section of the data base. + */ +void full_lst(fname) +char *fname; + { + unsigned hashval; + struct srcfile *sfile; + struct cfile *clst; + struct fileparts *fp; + FILE *f; + + f = fopen(fname, "w"); + if (f == NULL) + err2("cannot open ", fname); + for (hashval = 0; hashval < DHSize; ++hashval) + for (sfile = dhash[hashval]; sfile != NULL; sfile = sfile->next) + for (clst = sfile->dependents; clst != NULL; clst = clst->next) { + /* + * Remove the suffix from the name before printing. + */ + fp = fparse(clst->name); + fprintf(f, "%s\n", fp->name); + } + if (fclose(f) != 0) + err2("cannot close ", fname); + } + +/* + * impl_fnc - find or create implementation struct for function currently + * being parsed. + */ +void impl_fnc(name) +struct token *name; + { + /* + * Set the global operation type for later use. If this is a + * new function update the number of them. + */ + op_type = TokFunction; + num_fnc = set_impl(name, bhash, num_fnc, fnc_pre); + } + +/* + * impl_key - find or create implementation struct for keyword currently + * being parsed. + */ +void impl_key(name) +struct token *name; + { + /* + * Set the global operation type for later use. If this is a + * new keyword update the number of them. + */ + op_type = Keyword; + num_key = set_impl(name, khash, num_key, key_pre); + } + +/* + * set_impl - lookup a function or keyword in a hash table and update the + * entry, creating the entry if needed. + */ +static int set_impl(name, tbl, num_impl, pre) +struct token *name; +struct implement **tbl; +int num_impl; +char *pre; + { + register struct implement *ptr; + char *name_s; + unsigned hashval; + + /* + * we only need the operation name and not the entire token. + */ + name_s = name->image; + free_t(name); + + /* + * If the operation is not in the hash table, put it there. + */ + if ((ptr = db_ilkup(name_s, tbl)) == NULL) { + ptr = NewStruct(implement); + hashval = IHasher(name_s); + ptr->blink = tbl[hashval]; + ptr->oper_typ = ((op_type == TokFunction) ? 'F' : 'K'); + nxt_pre(ptr->prefix, pre, 2); /* allocate a unique prefix */ + ptr->name = name_s; + ptr->op = NULL; + tbl[hashval] = ptr; + ++num_impl; + } + + cur_impl = ptr; /* put entry in global variable for later access */ + + /* + * initialize the entry based on global information set during parsing. + */ + set_prms(ptr); + ptr->min_result = min_rs; + ptr->max_result = max_rs; + ptr->resume = rsm_rs; + ptr->ret_flag = 0; + if (comment == NULL) + ptr->comment = ""; + else { + ptr->comment = comment->image; + free_t(comment); + comment = NULL; + } + ptr->ntnds = 0; + ptr->tnds = NULL; + ptr->nvars = 0; + ptr->vars = NULL; + ptr->in_line = NULL; + ptr->iconc_flgs = 0; + return num_impl; + } + +/* + * set_prms - set the parameter information of an implementation based on + * the params list constructed during parsing. + */ +static void set_prms(ptr) +struct implement *ptr; + { + struct sym_entry *sym; + int nargs; + int i; + + /* + * Create an array of parameter flags for the operation. The flag + * indicates the deref/underef and varargs status for each parameter. + */ + if (params == NULL) { + ptr->nargs = 0; + ptr->arg_flgs = NULL; + } + else { + /* + * The parameters are in reverse order, so the number of the parameters + * can be determined by the number assigned to the first one on the + * list. + */ + nargs = params->u.param_info.param_num + 1; + ptr->nargs = nargs; + ptr->arg_flgs = alloc(nargs * sizeof(int)); + for (i = 0; i < nargs; ++i) + ptr->arg_flgs[i] = 0; + for (sym = params; sym != NULL; sym = sym->u.param_info.next) + ptr->arg_flgs[sym->u.param_info.param_num] |= sym->id_type; + } + } + +/* + * impl_op - find or create implementation struct for operator currently + * being parsed. + */ +void impl_op(op_sym, name) +struct token *op_sym; +struct token *name; + { + register struct implement *ptr; + char *op; + int nargs; + unsigned hashval; + + /* + * The operator symbol is needed but not the entire token. + */ + op = op_sym->image; + free_t(op_sym); + + /* + * The parameters are in reverse order, so the number of the parameters + * can be determined by the number assigned to the first one on the + * list. + */ + if (params == NULL) + nargs = 0; + else + nargs = params->u.param_info.param_num + 1; + + /* + * Locate the operator in the hash table; it must match both the + * operator symbol and the number of arguments. If the operator is + * not there, create an entry. + */ + hashval = IHasher(op); + ptr = ohash[hashval]; + while (ptr != NULL && (ptr->op != op || ptr->nargs != nargs)) + ptr = ptr->blink; + if (ptr == NULL) { + ptr = NewStruct(implement); + ptr->blink = ohash[hashval]; + ptr->oper_typ = 'O'; + nxt_pre(ptr->prefix, op_pre, 2); /* allocate a unique prefix */ + ptr->op = op; + ohash[hashval] = ptr; + ++num_op; + } + + /* + * Put the entry and operation type in global variables for + * later access. + */ + cur_impl = ptr; + op_type = Operator; + + /* + * initialize the entry based on global information set during parsing. + */ + ptr->name = name->image; + free_t(name); + set_prms(ptr); + ptr->min_result = min_rs; + ptr->max_result = max_rs; + ptr->resume = rsm_rs; + ptr->ret_flag = 0; + if (comment == NULL) + ptr->comment = ""; + else { + ptr->comment = comment->image; + free_t(comment); + comment = NULL; + } + ptr->ntnds = 0; + ptr->tnds = NULL; + ptr->nvars = 0; + ptr->vars = NULL; + ptr->in_line = NULL; + ptr->iconc_flgs = 0; + } + +/* + * set_r_seq - save result sequence information for updating the + * operation entry. + */ +void set_r_seq(min, max, resume) +long min; +long max; +int resume; + { + if (min == UnbndSeq) + min = 0; + min_rs = min; + max_rs = max; + rsm_rs = resume; + } + diff --git a/src/rtt/rttgram.y b/src/rtt/rttgram.y new file mode 100644 index 0000000..bf47752 --- /dev/null +++ b/src/rtt/rttgram.y @@ -0,0 +1,1101 @@ +/* + * Grammar for RTL. The C portion of the grammar is based on + * the ANSI Draft Standard - 3rd review. + */ + +%{ +#include "rtt1.h" +#define YYMAXDEPTH 250 +%} + +%union { + struct token *t; + struct node *n; + long i; + } + +%token Identifier StrLit LStrLit FltConst DblConst LDblConst +%token CharConst LCharConst IntConst UIntConst LIntConst ULIntConst +%token Arrow Incr Decr LShft RShft Leq Geq Equal Neq +%token And Or MultAsgn DivAsgn ModAsgn PlusAsgn +%token MinusAsgn LShftAsgn RShftAsgn AndAsgn +%token XorAsgn OrAsgn Sizeof Intersect OpSym + +%token Typedef Extern Static Auto Register Tended +%token Char Short Int Long Signed Unsigned Float Doubl Const Volatile +%token Void TypeDefName Struct Union Enum Ellipsis + +%token Case Default If Else Switch While Do For Goto Continue Break Return + +%token '%' '&' '(' ')' '*' '+' ',' '-' '.' '/' '{' '|' '}' '~' '[' ']' +%token '^' ':' ';' '<' '=' '>' '?' '!' '@' '\\' + +%token Runerr Is Cnv Def Exact Empty_type IconType Component Variable +%token Any_value Named_var Struct_var C_Integer Arith_case +%token C_Double C_String Tmp_string Tmp_cset Body End Function Keyword +%token Operator Underef Declare Suspend Fail Inline Abstract Store +%token Type New All_fields Then Type_case Of Len_case Constant Errorfail + +%type unary_op assign_op struct_or_union typedefname +%type identifier op_name key_const union attrb_name + +%type any_ident storage_class_spec type_qual +%type primary_expr postfix_expr arg_expr_lst unary_expr cast_expr +%type multiplicative_expr additive_expr shift_expr relational_expr +%type equality_expr and_expr exclusive_or_expr inclusive_or_expr +%type logical_and_expr logical_or_expr conditional_expr assign_expr +%type expr opt_expr constant_expr opt_constant_expr dcltion +%type typ_dcltion_specs dcltion_specs type_ind type_storcl_tqual_lst +%type storcl_tqual_lst init_dcltor_lst no_tdn_init_dcltor_lst init_dcltor +%type no_tdn_init_dcltor type_spec stnd_type struct_or_union_spec +%type struct_dcltion_lst struct_dcltion struct_dcltion_specs struct_type_ind +%type struct_type_lst struct_dcltor_lst struct_dcltor +%type struct_no_tdn_dcltor_lst struct_no_tdn_dcltor enum_spec enumerator_lst +%type enumerator dcltor no_tdn_dcltor direct_dcltor no_tdn_direct_dcltor +%type pointer opt_pointer tqual_lst param_type_lst opt_param_type_lst +%type param_lst param_dcltion ident_lst type_tqual_lst type_name +%type abstract_dcltor direct_abstract_dcltor initializer initializer_lst +%type stmt labeled_stmt compound_stmt dcltion_lst opt_dcltion_lst stmt_lst +%type expr_stmt selection_stmt iteration_stmt jump_stmt parm_dcls_or_ids +%type func_head opt_stmt_lst local_dcls local_dcl +%type dest_type i_type_name opt_actions actions action ret_val detail_code +%type runerr variable checking_conversions label +%type type_check type_select_lst opt_default type_select selector_lst +%type c_opt_default c_type_select c_type_select_lst non_lbl_stmt +%type simple_check_conj simple_check len_select_lst len_select +%type type_computations side_effect_lst side_effect +%type type basic_type type_lst + +%type opt_plus length + +/* Get rid of shift/reduce conflict on Else. Use precedence to force shift of + Else rather than reduction of if-cond-expr. This insures that the Else + is always paired with innermost If. Note, IfStmt is a dummy token. */ +%nonassoc IfStmt +%nonassoc Else + +%start translation_unit +%% + +primary_expr + : identifier {$$ = sym_node($1);} + | StrLit {$$ = node0(PrimryNd, $1);} + | LStrLit {$$ = node0(PrimryNd, $1);} + | FltConst {$$ = node0(PrimryNd, $1);} + | DblConst {$$ = node0(PrimryNd, $1);} + | LDblConst {$$ = node0(PrimryNd, $1);} + | CharConst {$$ = node0(PrimryNd, $1);} + | LCharConst {$$ = node0(PrimryNd, $1);} + | IntConst {$$ = node0(PrimryNd, $1);} + | UIntConst {$$ = node0(PrimryNd, $1);} + | LIntConst {$$ = node0(PrimryNd, $1);} + | ULIntConst {$$ = node0(PrimryNd, $1);} + | '(' expr ')' {$$ = node1(PrefxNd, $1, $2); free_t($3);} + ; + +postfix_expr + : primary_expr + | postfix_expr '[' expr ']' {$$ = node2(BinryNd, $2, $1, $3); + free_t($4);} + | postfix_expr '(' ')' {$$ = node2(BinryNd, $3, $1, NULL); + free_t($2);} + | postfix_expr '(' arg_expr_lst ')' {$$ = node2(BinryNd, $4, $1, $3); + free_t($2);} + | postfix_expr '.' any_ident {$$ = node2(BinryNd, $2, $1, $3);} + | postfix_expr Arrow any_ident {$$ = node2(BinryNd, $2, $1, $3);} + | postfix_expr Incr {$$ = node1(PstfxNd, $2, $1);} + | postfix_expr Decr {$$ = node1(PstfxNd, $2, $1);} + | Is ':' i_type_name '(' assign_expr ')' + {$$ = node2(BinryNd, $1, $3, $5); free_t($2); free_t($4); free_t($6);} + | Cnv ':' dest_type '(' assign_expr ',' assign_expr ')' + {$$ = node3(TrnryNd, $1, $3, $5, $7), free_t($2); free_t($4); free_t($6); + free_t($8);} + | Def ':' dest_type '(' assign_expr ',' assign_expr ',' assign_expr ')' + {$$ = node4(QuadNd, $1, $3, $5, $7, $9), free_t($2); free_t($4); + free_t($6); free_t($8); free_t($10);} + ; + +arg_expr_lst + : assign_expr + | arg_expr_lst ',' assign_expr {$$ = node2(CommaNd, $2, $1, $3);} + ; + +unary_expr + : postfix_expr + | Incr unary_expr {$$ = node1(PrefxNd, $1, $2);} + | Decr unary_expr {$$ = node1(PrefxNd, $1, $2);} + | unary_op cast_expr {$$ = node1(PrefxNd, $1, $2);} + | Sizeof unary_expr {$$ = node1(PrefxNd, $1, $2);} + | Sizeof '(' type_name ')' {$$ = node1(PrefxNd, $1, $3); + free_t($2); free_t($4);} + ; + +unary_op + : '&' + | '*' + | '+' + | '-' + | '~' + | '!' + ; + +cast_expr + : unary_expr + | '(' type_name ')' cast_expr {$$ = node2(BinryNd, $1, $2, $4); free_t($3);} + ; + +multiplicative_expr + : cast_expr + | multiplicative_expr '*' cast_expr {$$ = node2(BinryNd, $2, $1, $3);} + | multiplicative_expr '/' cast_expr {$$ = node2(BinryNd, $2, $1, $3);} + | multiplicative_expr '%' cast_expr {$$ = node2(BinryNd, $2, $1, $3);} + ; + +additive_expr + : multiplicative_expr + | additive_expr '+' multiplicative_expr {$$ = node2(BinryNd, $2, $1, $3);} + | additive_expr '-' multiplicative_expr {$$ = node2(BinryNd, $2, $1, $3);} + ; + +shift_expr + : additive_expr + | shift_expr LShft additive_expr {$$ = node2(BinryNd, $2, $1, $3);} + | shift_expr RShft additive_expr {$$ = node2(BinryNd, $2, $1, $3);} + ; + +relational_expr + : shift_expr + | relational_expr '<' shift_expr {$$ = node2(BinryNd, $2, $1, $3);} + | relational_expr '>' shift_expr {$$ = node2(BinryNd, $2, $1, $3);} + | relational_expr Leq shift_expr {$$ = node2(BinryNd, $2, $1, $3);} + | relational_expr Geq shift_expr {$$ = node2(BinryNd, $2, $1, $3);} + ; + +equality_expr + : relational_expr + | equality_expr Equal relational_expr {$$ = node2(BinryNd, $2, $1, $3);} + | equality_expr Neq relational_expr {$$ = node2(BinryNd, $2, $1, $3);} + ; + +and_expr + : equality_expr + | and_expr '&' equality_expr {$$ = node2(BinryNd, $2, $1, $3);} + ; + +exclusive_or_expr + : and_expr + | exclusive_or_expr '^' and_expr {$$ = node2(BinryNd, $2, $1, $3);} + ; + +inclusive_or_expr + : exclusive_or_expr + | inclusive_or_expr '|' exclusive_or_expr {$$ = node2(BinryNd, $2, $1, $3);} + ; + +logical_and_expr + : inclusive_or_expr + | logical_and_expr And inclusive_or_expr {$$ = node2(BinryNd, $2, $1, $3);} + ; + +logical_or_expr + : logical_and_expr + | logical_or_expr Or logical_and_expr {$$ = node2(BinryNd, $2, $1, $3);} + ; + +conditional_expr + : logical_or_expr + | logical_or_expr '?' expr ':' conditional_expr + {$$ = node3(TrnryNd, $2, $1, $3, $5); + free_t($4);} + ; + +assign_expr + : conditional_expr + | unary_expr assign_op assign_expr {$$ = node2(BinryNd, $2, $1, $3);} + ; + +assign_op + : '=' + | MultAsgn + | DivAsgn + | ModAsgn + | PlusAsgn + | MinusAsgn + | LShftAsgn + | RShftAsgn + | AndAsgn + | XorAsgn + | OrAsgn + ; + +expr + : assign_expr + | expr ',' assign_expr {$$ = node2(BinryNd, $2, $1, $3);} + ; + +opt_expr + : {$$ = NULL;} + | expr + ; + +constant_expr + : conditional_expr + ; + +opt_constant_expr + : {$$ = NULL;} + | constant_expr + ; + +dcltion + : typ_dcltion_specs ';' {$$ = node2(BinryNd, $2, $1, NULL); + dcl_stk->kind_dcl = OtherDcl;} + | typ_dcltion_specs init_dcltor_lst ';' {$$ = node2(BinryNd, $3, $1, $2); + dcl_stk->kind_dcl = OtherDcl;} + | storcl_tqual_lst no_tdn_init_dcltor_lst ';' + {$$ = node2(BinryNd, $3, $1, $2); + dcl_stk->kind_dcl = OtherDcl;} + ; + +typ_dcltion_specs + : type_ind + | storcl_tqual_lst type_ind {$$ = node2(LstNd, NULL, $1, $2);} + ; + +dcltion_specs + : typ_dcltion_specs + | storcl_tqual_lst + ; + +type_ind + : typedefname {$$ = node0(PrimryNd, $1);} + | typedefname storcl_tqual_lst + {$$ = node2(LstNd, NULL, node0(PrimryNd, $1), $2);} + | type_storcl_tqual_lst + ; + +type_storcl_tqual_lst + : stnd_type + | type_storcl_tqual_lst stnd_type {$$ = node2(LstNd, NULL, $1, $2);} + | type_storcl_tqual_lst storage_class_spec {$$ = node2(LstNd, NULL, $1, $2);} + | type_storcl_tqual_lst type_qual {$$ = node2(LstNd, NULL, $1, $2);} + ; + +storcl_tqual_lst + : storage_class_spec + | type_qual + | storcl_tqual_lst storage_class_spec {$$ = node2(LstNd, NULL, $1, $2);} + | storcl_tqual_lst type_qual {$$ = node2(LstNd, NULL, $1, $2);} + ; + +init_dcltor_lst + : init_dcltor + | init_dcltor_lst ',' init_dcltor {$$ = node2(CommaNd, $2, $1, $3);} + ; + +no_tdn_init_dcltor_lst + : no_tdn_init_dcltor + | no_tdn_init_dcltor_lst ',' no_tdn_init_dcltor + {$$ = node2(CommaNd, $2, $1, $3);} + ; + +init_dcltor + : dcltor {$$ = $1; id_def($1, NULL);} + | dcltor '=' initializer {$$ = node2(BinryNd, $2, $1, $3); id_def($1, $3);} + ; + +no_tdn_init_dcltor + : no_tdn_dcltor {$$ = $1; id_def($1, NULL);} + | no_tdn_dcltor '=' initializer + {$$ = node2(BinryNd, $2, $1, $3); id_def($1, $3);} + ; + +storage_class_spec + : Typedef {$$ = node0(PrimryNd, $1); dcl_stk->kind_dcl = IsTypedef;} + | Extern {$$ = node0(PrimryNd, $1);} + | Static {$$ = node0(PrimryNd, $1);} + | Auto {$$ = node0(PrimryNd, $1);} + | Register {$$ = node0(PrimryNd, $1);} + ; + +type_spec + : stnd_type + | typedefname {$$ = node0(PrimryNd, $1);} + ; + +stnd_type + : Void {$$ = node0(PrimryNd, $1);} + | Char {$$ = node0(PrimryNd, $1);} + | Short {$$ = node0(PrimryNd, $1);} + | Int {$$ = node0(PrimryNd, $1);} + | Long {$$ = node0(PrimryNd, $1);} + | Float {$$ = node0(PrimryNd, $1);} + | Doubl {$$ = node0(PrimryNd, $1);} + | Signed {$$ = node0(PrimryNd, $1);} + | Unsigned {$$ = node0(PrimryNd, $1);} + | struct_or_union_spec + | enum_spec + ; + +struct_or_union_spec + : struct_or_union any_ident '{' struct_dcltion_lst '}' + {$$ = node2(BinryNd, $1, $2, $4); + free_t($3); free_t($5);} + | struct_or_union '{' struct_dcltion_lst '}' + {$$ = node2(BinryNd, $1, NULL, $3); + free_t($2); free_t($4);} + | struct_or_union any_ident {$$ = node2(BinryNd, $1, $2, NULL);} + ; + +struct_or_union + : Struct + | Union + ; + +struct_dcltion_lst + : struct_dcltion + | struct_dcltion_lst struct_dcltion {$$ = node2(LstNd, NULL, $1, $2);} + ; + +struct_dcltion + : struct_dcltion_specs struct_dcltor_lst ';' + {$$ = node2(BinryNd, $3, $1, $2);} + | tqual_lst struct_no_tdn_dcltor_lst ';' {$$ = node2(BinryNd, $3, $1, $2);} + ; + +struct_dcltion_specs + : struct_type_ind + | tqual_lst struct_type_ind {$$ = node2(LstNd, NULL, $1, $2);} + ; + +struct_type_ind + : typedefname {$$ = node0(PrimryNd, $1);} + | typedefname tqual_lst {$$ = node2(LstNd, NULL, node0(PrimryNd, $1), $2);} + | struct_type_lst + ; + +struct_type_lst + : stnd_type + | struct_type_lst stnd_type {$$ = node2(LstNd, NULL, $1, $2);} + | struct_type_lst type_qual {$$ = node2(LstNd, NULL, $1, $2);} ; + +struct_dcltor_lst + : struct_dcltor + | struct_dcltor_lst ',' struct_dcltor {$$ = node2(CommaNd, $2, $1, $3);} + ; + +struct_dcltor + : dcltor {$$ = node2(StrDclNd, NULL, $1, NULL); + if (dcl_stk->parms_done) pop_cntxt();} + | ':' constant_expr {$$ = node2(StrDclNd, $1, NULL, $2);} + | dcltor ':' {if (dcl_stk->parms_done) pop_cntxt();} constant_expr + {$$ = node2(StrDclNd, $2, $1, $4);} + ; + +struct_no_tdn_dcltor_lst + : struct_no_tdn_dcltor + | struct_no_tdn_dcltor_lst ',' struct_no_tdn_dcltor + {$$ = node2(CommaNd, $2, $1, $3);} + ; + +struct_no_tdn_dcltor + : no_tdn_dcltor {$$ = node2(StrDclNd, NULL, $1, NULL); + if (dcl_stk->parms_done) pop_cntxt();} + | ':' constant_expr {$$ = node2(StrDclNd, $1, NULL, $2);} + | no_tdn_dcltor ':' {if (dcl_stk->parms_done) pop_cntxt();} constant_expr + {$$ = node2(StrDclNd, $2, $1, $4);} + ; + +enum_spec + : Enum {push_cntxt(0);} '{' enumerator_lst '}' + {$$ = node2(BinryNd, $1, NULL, $4); pop_cntxt(); free_t($3); free_t($5);} + | Enum any_ident {push_cntxt(0);} '{' enumerator_lst '}' + {$$ = node2(BinryNd, $1, $2, $5); pop_cntxt(); free_t($4); free_t($6);} + | Enum any_ident {$$ = node2(BinryNd, $1, $2, NULL);} + ; + +enumerator_lst + : enumerator + | enumerator_lst ',' enumerator {$$ = node2(CommaNd, $2, $1, $3);} + ; + +enumerator + : any_ident {$$ = $1; id_def($1, NULL);} + | any_ident '=' constant_expr + {$$ = node2(BinryNd, $2, $1, $3); id_def($1, $3);} + ; + +type_qual + : Const {$$ = node0(PrimryNd, $1);} + | Volatile {$$ = node0(PrimryNd, $1);} + ; + + +dcltor + : opt_pointer direct_dcltor {$$ = node2(ConCatNd, NULL, $1, $2);} + ; + +no_tdn_dcltor + : opt_pointer no_tdn_direct_dcltor {$$ = node2(ConCatNd, NULL, $1, $2);} + ; + +direct_dcltor + : any_ident + | '(' dcltor ')' {$$ = node1(PrefxNd, $1, $2); + free_t($3);} + | direct_dcltor '[' opt_constant_expr ']' {$$ = node2(BinryNd, $2, $1, $3); + free_t($4);} + | direct_dcltor '(' {push_cntxt(1);} parm_dcls_or_ids ')' + {$$ = node2(BinryNd, $5, $1, $4); + if (dcl_stk->nest_lvl == 2) + dcl_stk->parms_done = 1; + else + pop_cntxt(); + free_t($2);} + ; + +no_tdn_direct_dcltor + : identifier {$$ = node0(PrimryNd, $1);} + | '(' no_tdn_dcltor ')' {$$ = node1(PrefxNd, $1, $2); + free_t($3);} + | no_tdn_direct_dcltor '[' opt_constant_expr ']' + {$$ = node2(BinryNd, $2, $1, $3); + free_t($4);} + | no_tdn_direct_dcltor '(' {push_cntxt(1);} parm_dcls_or_ids ')' + {$$ = node2(BinryNd, $5, $1, $4); + if (dcl_stk->nest_lvl == 2) + dcl_stk->parms_done = 1; + else + pop_cntxt(); + free_t($2);} + ; + +parm_dcls_or_ids + : opt_param_type_lst + | ident_lst + ; + +pointer + : '*' {$$ = node0(PrimryNd, $1);} + | '*' tqual_lst {$$ = node1(PreSpcNd, $1, $2);} + | '*' pointer {$$ = node1(PrefxNd, $1, $2);} + | '*' tqual_lst pointer {$$ = node1(PrefxNd, $1, node2(LstNd, NULL, $2,$3));} + ; + +opt_pointer + : {$$ = NULL;} + | pointer + ; + +tqual_lst + : type_qual + | tqual_lst type_qual {$$ = node2(LstNd, NULL, $1, $2);} + ; + +param_type_lst + : param_lst + | param_lst ',' Ellipsis {$$ = node2(CommaNd, $2, $1, node0(PrimryNd, $3));} + ; + +opt_param_type_lst + : {$$ = NULL;} + | param_type_lst + ; + +param_lst + : param_dcltion + | param_lst ',' param_dcltion {$$ = node2(CommaNd, $2, $1, $3);} + ; + +param_dcltion + : dcltion_specs no_tdn_dcltor {$$ = node2(LstNd, NULL, $1, $2); + id_def($2, NULL);} + | dcltion_specs + | dcltion_specs abstract_dcltor {$$ = node2(LstNd, NULL, $1, $2);} + ; + +ident_lst + : identifier {$$ = node0(PrimryNd, $1);} + | ident_lst ',' identifier {$$ = node2(CommaNd, $2, $1, node0(PrimryNd,$3));} + ; + +type_tqual_lst + : type_spec + | type_qual + | type_spec type_tqual_lst {$$ = node2(LstNd, NULL, $1, $2);} + | type_qual type_tqual_lst {$$ = node2(LstNd, NULL, $1, $2);} + ; + +type_name + : type_tqual_lst + | type_tqual_lst abstract_dcltor {$$ = node2(LstNd, NULL, $1, $2);} + ; + +abstract_dcltor + : pointer + | opt_pointer direct_abstract_dcltor {$$ = node2(ConCatNd, NULL, $1, $2);} + ; + +direct_abstract_dcltor + : '(' abstract_dcltor ')' {$$ = node1(PrefxNd, $1, $2); + free_t($3);} + | '[' opt_constant_expr ']' + {$$ = node2(BinryNd, $1, NULL, $2); + free_t($3);} + | direct_abstract_dcltor '[' opt_constant_expr ']' + {$$ = node2(BinryNd, $2, $1, $3); + free_t($4);} + | '(' {push_cntxt(1);} opt_param_type_lst ')' + {$$ = node2(BinryNd, $4, NULL, $3); + pop_cntxt(); + free_t($1);} + | direct_abstract_dcltor '(' {push_cntxt(1);} opt_param_type_lst ')' + {$$ = node2(BinryNd, $5, $1, $4); + pop_cntxt(); + free_t($2);} + ; + +initializer + : assign_expr + | '{' initializer_lst '}' + {$$ = node1(PrefxNd, $1, $2); free_t($3);} + | '{' initializer_lst ',' '}' + {$$ = node1(PrefxNd, $1, node2(CommaNd, $3, $2, NULL)); + free_t($4);} + ; + +initializer_lst + : initializer + | initializer_lst ',' initializer {$$ = node2(CommaNd, $2, $1, $3);} + ; + +stmt + : labeled_stmt + | non_lbl_stmt + ; + +non_lbl_stmt + : {push_cntxt(1);} compound_stmt {$$ = $2; pop_cntxt();} + | expr_stmt + | selection_stmt + | iteration_stmt + | jump_stmt + | Runerr '(' assign_expr ')' ';' + {$$ = node2(BinryNd, $1, $3, NULL); free_t($2); free_t($4);} + | Runerr '(' assign_expr ',' assign_expr ')' ';' + {$$ = node2(BinryNd, $1, $3, $5); free_t($2); free_t($4); free_t($6);} + ; + +labeled_stmt + : label ':' stmt {$$ = node2(BinryNd, $2, $1, $3);} + | Case constant_expr ':' stmt {$$ = node2(BinryNd, $1, $2, $4); free_t($3);} + | Default ':' stmt {$$ = node1(PrefxNd, $1, $3); free_t($2);} + ; + +compound_stmt + : '{' opt_stmt_lst '}' {$$ = comp_nd($1, NULL, $2); free_t($3);} + | '{' local_dcls opt_stmt_lst '}' {$$ = comp_nd($1, $2, $3); free_t($4);} + ; + +dcltion_lst + : dcltion + | dcltion_lst dcltion {$$ = node2(LstNd, NULL, $1, $2);} + ; + +opt_dcltion_lst + : {$$ = NULL;} + | dcltion_lst + ; + +local_dcls + : local_dcl + | local_dcls local_dcl {$$ = ($2 == NULL ? $1 : node2(LstNd, NULL, $1, $2));} + ; + +local_dcl + : dcltion + | Tended tended_type init_dcltor_lst ';' + {$$ = NULL; free_t($1); free_t($4); dcl_stk->kind_dcl = OtherDcl;} + ; + +tended_type + : Char {tnd_char(); free_t($1);} + | Struct identifier {tnd_strct($2); free_t($1);} + | Struct TypeDefName {tnd_strct($2); free_t($1);} + | Union identifier {tnd_union($2); free_t($1);} + ; + +stmt_lst + : stmt + | stmt_lst stmt {$$ = node2(ConCatNd, NULL, $1, $2);} + ; + +opt_stmt_lst + : {$$ = NULL;} + | stmt_lst + ; +expr_stmt + : opt_expr ';' {$$ = node1(PstfxNd, $2, $1);} + ; + +selection_stmt + : If '(' expr ')' stmt %prec IfStmt {$$ = node3(TrnryNd, $1, $3, $5,NULL); + free_t($2); free_t($4);} + | If '(' expr ')' stmt Else stmt {$$ = node3(TrnryNd, $1, $3, $5, $7); + free_t($2); free_t($4); free_t($6);} + | Switch '(' expr ')' stmt {$$ = node2(BinryNd, $1, $3, $5); + free_t($2); free_t($4);} + | Type_case expr Of '{' c_type_select_lst c_opt_default '}' + {$$ = node3(TrnryNd, $1, $2, $5, $6); free_t($3); free_t($4); free_t($7);} + ; + +c_type_select_lst + : c_type_select {$$ = node2(ConCatNd, NULL, NULL, $1);} + | c_type_select_lst c_type_select {$$ = node2(ConCatNd, NULL, $1, $2);} + ; + +c_type_select + : selector_lst non_lbl_stmt {$$ = node2(ConCatNd, NULL, $1, $2);} + ; + +c_opt_default + : {$$ = NULL;} + | Default ':' non_lbl_stmt {$$ = $3; free_t($1); free_t($2);} + ; + +iteration_stmt + : While '(' expr ')' stmt {$$ = node2(BinryNd, $1, $3, $5); + free_t($2); free_t($4);} + | Do stmt While '(' expr ')' ';' {$$ = node2(BinryNd, $1, $2, $5); + free_t($3); free_t($4); free_t($6); + free_t($7);} + | For '(' opt_expr ';' opt_expr ';' opt_expr ')' stmt + {$$ = node4(QuadNd, $1, $3, $5, $7, $9); + free_t($2); free_t($4); free_t($6); + free_t($8);} + ; + +jump_stmt + : Goto label';' {$$ = node1(PrefxNd, $1, $2); free_t($3);} + | Continue ';' {$$ = node0(PrimryNd, $1); free_t($2);} + | Break ';' {$$ = node0(PrimryNd, $1); free_t($2);} + | Return ret_val ';' {$$ = node1(PrefxNd, $1, $2); free_t($3);} + | Suspend ret_val ';' {$$ = node1(PrefxNd, $1, $2); free_t($3);} + | Fail ';' {$$ = node0(PrimryNd, $1); free_t($2);} + | Errorfail ';' {$$ = node0(PrimryNd, $1); free_t($2);} + ; + +translation_unit + : + | extrn_decltn_lst + ; + +extrn_decltn_lst + : external_dcltion + | extrn_decltn_lst external_dcltion + ; + +external_dcltion + : function_definition + | dcltion {dclout($1);} + | definition + ; + +function_definition + : func_head {func_def($1);} opt_dcltion_lst compound_stmt + {fncout($1, $3, $4);} + ; + +func_head + : no_tdn_dcltor {$$ = node2(LstNd, NULL, NULL, $1);} + | storcl_tqual_lst no_tdn_dcltor {$$ = node2(LstNd, NULL, $1, $2);} + | typ_dcltion_specs dcltor {$$ = node2(LstNd, NULL, $1, $2);} + ; + +any_ident + : identifier {$$ = node0(PrimryNd, $1);} + | typedefname {$$ = node0(PrimryNd, $1);} + ; + +label + : identifier {$$ = lbl($1);} + | typedefname {$$ = lbl($1);} + ; + +typedefname + : TypeDefName + | C_Integer /* hack to allow C_integer to be defined with typedef */ + | C_Double /* for consistency with C_integer */ + | C_String /* for consistency with C_integer */ + ; + +/* + * The rest of the grammar implements the interface portion of the language. + */ + +definition + : {strt_def();} description operation + ; + +operation + : fnc_oper op_declare actions End {defout($3); free_t($4);} + | keyword actions End {defout($2); free_t($3);} + | keyword Constant key_const End {keyconst($3); free_t($2); free_t($4);} + ; + +description + : {comment = NULL;} + | StrLit {comment = $1;} + ; + +fnc_oper + : Function '{' result_seq '}' op_name '(' opt_s_parm_lst ')' + {impl_fnc($5); free_t($1); free_t($2); free_t($4); free_t($6); + free_t($8);} + | Operator '{' result_seq {lex_state = OpHead;} '}' OpSym + {lex_state = DfltLex;} op_name '(' opt_s_parm_lst ')' + {impl_op($6, $8); free_t($1); free_t($2); free_t($5); free_t($9); + free_t($11);} + +keyword + : Keyword '{' result_seq '}' op_name + {impl_key($5); free_t($1); free_t($2); free_t($4);} + ; + +key_const + : StrLit + | CharConst + | DblConst + | IntConst + ; + +/* + * Allow as many special names to be identifiers as possible + */ +identifier + : Abstract + | All_fields + | Any_value + | Body + | Component + | Declare + | Empty_type + | End + | Exact + | IconType + | Identifier + | Inline + | Named_var + | New + | Of + | Store + | Struct_var + | Then + | Tmp_cset + | Tmp_string + | Type + | Underef + | Variable + ; + +/* + * an operation may be given any name. + */ +op_name + : identifier + | typedefname + | Auto + | Break + | Case + | Char + | Cnv + | Const + | Continue + | Def + | Default + | Do + | Doubl + | Else + | Enum + | Errorfail + | Extern + | Fail + | Float + | For + | Function + | Goto + | If + | Int + | Is + | Keyword + | Long + | Operator + | Register + | Return + | Runerr + | Short + | Signed + | Sizeof + | Static + | Struct + | Suspend + | Switch + | Tended + | Typedef + | Union + | Unsigned + | Void + | Volatile + | While + ; + +result_seq + : {set_r_seq(NoRsltSeq, NoRsltSeq, 0);} + | length opt_plus {set_r_seq($1, $1, (int)$2);} + | length ',' length opt_plus {set_r_seq($1, $3, (int)$4); free_t($2);} + ; + +length + : IntConst {$$ = ttol($1); free_t($1);} + | '*' {$$ = UnbndSeq; free_t($1);} + ; + +opt_plus + : {$$ = 0;} + | '+' {$$ = 1; free_t($1);} + ; + +opt_s_parm_lst + : + | s_parm_lst + | s_parm_lst '[' identifier ']' {var_args($3); free_t($2); free_t($4);} + ; + +s_parm_lst + : s_parm + | s_parm_lst ',' s_parm {free_t($2);} + ; + +s_parm + : identifier {s_prm_def(NULL, $1);} + | Underef identifier {s_prm_def($2, NULL); free_t($1);} + | Underef identifier Arrow identifier {s_prm_def($2, $4); free_t($1); + free_t($3);} + ; + +op_declare + : {} + | Declare '{' local_dcls '}' {d_lst_typ($3); free_t($1); free_t($2); + free_t($4);} + ; + +opt_actions + : {$$ = NULL;} + | actions + ; + +actions + : action + | actions action {$$ = node2(ConCatNd, NULL, $1, $2);} + ; + +action + : checking_conversions + | detail_code + | runerr + | '{' opt_actions '}' {$$ = node1(PrefxNd, $1, $2); free_t($3);} + | Abstract {lex_state = TypeComp;} '{' type_computations + {lex_state = DfltLex;} '}' + {$$ = $4; free_t($1); free_t($3); free_t($6);} + ; + +checking_conversions + : If type_check Then action %prec IfStmt + {$$ = node3(TrnryNd, $1, $2, $4, NULL); free_t($3);} + | If type_check Then action Else action + {$$ = node3(TrnryNd, $1, $2, $4, $6); free_t($3); free_t($5);} + | Type_case variable Of '{' type_select_lst opt_default '}' + {$$ = node3(TrnryNd, $1, $2, $5, $6); free_t($3); free_t($4); free_t($7);} + | Len_case identifier Of '{' len_select_lst Default ':' action '}' + {$$ = node3(TrnryNd, $1, sym_node($2), $5, $8); free_t($3), free_t($4); + free_t($6); free_t($7); free_t($9);} + | Arith_case '(' variable ',' variable ')' Of '{' + dest_type ':' action dest_type ':' action dest_type ':' action '}' + {$$ = arith_nd($1, $3, $5, $9, $11, $12, $14, $15, $17); free_t($2); + free_t($4), free_t($6); free_t($7); free_t($8); free_t($10); + free_t($13); free_t($16); free_t($18);} + ; + +type_select_lst + : type_select {$$ = node2(ConCatNd, NULL, NULL, $1);} + | type_select_lst type_select {$$ = node2(ConCatNd, NULL, $1, $2);} + ; + +type_select + : selector_lst action {$$ = node2(ConCatNd, NULL, $1, $2);} + ; + +opt_default + : {$$ = NULL;} + | Default ':' action {$$ = $3; free_t($1); free_t($2);} + ; + +selector_lst + : i_type_name ':' {$$ = node2(ConCatNd, NULL, NULL, $1); + free_t($2);} + | selector_lst i_type_name ':' {$$ = node2(ConCatNd, NULL, $1, $2); + free_t($3);} + ; + +len_select_lst + : len_select + | len_select_lst len_select {$$ = node2(ConCatNd, NULL, $1, $2);} + ; + +len_select + : IntConst ':' action {$$ = node1(PrefxNd, $1, $3); free_t($2);} + ; + +type_check + : simple_check_conj + | '!' simple_check {$$ = node1(PrefxNd, $1, $2);} + ; + +simple_check_conj + : simple_check + | simple_check_conj And simple_check {$$ = node2(BinryNd, $2, $1, $3);} + ; + +simple_check + : Is ':' i_type_name '(' variable ')' + {$$ = node2(BinryNd, $1, $3, $5); free_t($2); free_t($4); free_t($6);} + | Cnv ':' dest_type '(' variable ')' + {$$ = node3(TrnryNd, $1, $3, $5, NULL), dst_alloc($3, $5); free_t($2); + free_t($4); free_t($6);} + | Cnv ':' dest_type '(' variable ',' assign_expr ')' + {$$ = node3(TrnryNd, $1, $3, $5, $7), free_t($2); free_t($4); free_t($6); + free_t($8);} + | Def ':' dest_type '(' variable ',' assign_expr ')' + {$$ = node4(QuadNd, $1, $3, $5, $7, NULL), dst_alloc($3, $5); free_t($2); + free_t($4); free_t($6); free_t($8);} + | Def ':' dest_type '(' variable ',' assign_expr ',' assign_expr ')' + {$$ = node4(QuadNd, $1, $3, $5, $7, $9), free_t($2); free_t($4); + free_t($6); free_t($8); free_t($10);} + ; + +detail_code + : Body {push_cntxt(1);} compound_stmt + {$$ = node1(PrefxNd, $1, $3); pop_cntxt();} + | Inline {push_cntxt(1);} compound_stmt + {$$ = node1(PrefxNd, $1, $3); pop_cntxt();} + ; + +runerr + : Runerr '(' IntConst ')' opt_semi + {$$ = node2(BinryNd, $1, node0(PrimryNd, $3), NULL); + free_t($2); free_t($4);} + | Runerr '(' IntConst ',' variable ')' opt_semi + {$$ = node2(BinryNd, $1, node0(PrimryNd, $3), $5); + free_t($2); free_t($4); free_t($6);} + ; + +opt_semi + : + | ';' {free_t($1);} + ; + +variable + : identifier {$$ = sym_node($1);} + | identifier '[' IntConst ']' {$$ = node2(BinryNd, $2, sym_node($1), + node0(PrimryNd, $3)); + free_t($4);} + +dest_type + : IconType {$$ = dest_node($1);} + | C_Integer {$$ = node0(PrimryNd, $1);} + | C_Double {$$ = node0(PrimryNd, $1);} + | C_String {$$ = node0(PrimryNd, $1);} + | Tmp_string {$$ = node0(PrimryNd, $1); ++n_tmp_str;} + | Tmp_cset {$$ = node0(PrimryNd, $1); ++n_tmp_cset;} + | '(' Exact ')' IconType {$$ = node0(ExactCnv, chk_exct($4)); free_t($1); + free_t($2); free_t($3);} + | '(' Exact ')' C_Integer {$$ = node0(ExactCnv, $4); free_t($1); free_t($2); + free_t($3);} + ; + +i_type_name + : Any_value {$$ = node0(PrimryNd, $1);} + | Empty_type {$$ = node0(PrimryNd, $1);} + | IconType {$$ = sym_node($1);} + | Variable {$$ = node0(PrimryNd, $1);} + ; + +ret_val + : opt_expr + | C_Integer assign_expr {$$ = node1(PrefxNd, $1, $2);} + | C_Double assign_expr {$$ = node1(PrefxNd, $1, $2);} + | C_String assign_expr {$$ = node1(PrefxNd, $1, $2);} + ; + +type_computations + : side_effect_lst Return type opt_semi {$$ = node2(AbstrNd, $2, $1, $3);} + | Return type opt_semi {$$ = node2(AbstrNd, $1, NULL, $2);} + | side_effect_lst {$$ = node2(AbstrNd, NULL, $1, NULL);} + ; + +side_effect_lst + : side_effect + | side_effect_lst side_effect {$$ = node2(ConCatNd, NULL, $1, $2);} + ; + +side_effect + : Store '[' type ']' '=' type opt_semi {$$ = node2(BinryNd, $5, $3, $6); + free_t($1); free_t($2); free_t($4);} + ; + +type + : basic_type + | type union basic_type {$$ = node2(BinryNd, $2, $1, $3);} + | type Intersect basic_type {$$ = node2(BinryNd, $2, $1, $3);} + +basic_type + : i_type_name {$$ = node1(IcnTypNd, + copy_t($1->tok), $1);} + | Type '(' variable ')' {$$ = node1(PrefxNd, $1, $3); + free_t($2); free_t($4);} + | New i_type_name '(' type_lst ')' {$$ = node2(BinryNd, $1, $2, $4); + free_t($3); free_t($5);} + | Store '[' type ']' {$$ = node1(PrefxNd, $1, $3); + free_t($2); free_t($4);} + | basic_type '.' attrb_name {$$ = node1(PstfxNd, $3, $1); + free_t($2);} + | '(' type ')' {$$ = $2; free_t($1); free_t($3);} + ; + +union + : Incr + ; + +type_lst + : type + | type_lst ',' type {$$ = node2(CommaNd, $2, $1, $3);} + ; + +attrb_name + : Component + | All_fields + ; + +%% + +/* + * xfree(p) -- used with free(p) macro to avoid compiler errors from + * miscast free calls generated by Yacc. + */ +static void xfree(p) +char *p; +{ + free(p); +} + +#define free(p) xfree((char*)p) diff --git a/src/rtt/rttilc.c b/src/rtt/rttilc.c new file mode 100644 index 0000000..70839ef --- /dev/null +++ b/src/rtt/rttilc.c @@ -0,0 +1,1402 @@ +/* + * rttilc.c - routines to construct pieces of C code to put in the data base + * as in-line code. + * + * In-line C code is represented internally as a linked list of structures. + * The information contained in each structure depends on the type of code + * being represented. Some structures contain other fragments of C code. + * Code that does not require special processing is stored as strings. These + * strings are accumulated in a buffer until it is full or code that cannot + * be represented as a string must be produced. At that point, the string + * in placed in a structure and put on the list. + */ +#include "rtt.h" + +#ifndef Rttx + +/* + * prototypes for static functions. + */ +static void add_ptr (struct node *dcltor); +static void alloc_ilc (int il_c_type); +static void flush_str (void); +static void ilc_chnl (struct token *t); +static void ilc_cnv (struct node *cnv_typ, struct node *src, + struct node *dflt, struct node *dest); +static void ilc_cgoto (int neg, struct node *cond, word lbl); +static void ilc_goto (word lbl); +static void ilc_lbl (word lbl); +static void ilc_ret (struct token *t, int ilc_typ, struct node *n); +static void ilc_str (char *s); +static void ilc_tok (struct token *t); +static void ilc_var (struct sym_entry *sym, int just_desc, int may_mod); +static void ilc_walk (struct node *n, int may_mod, int const_cast); +static void init_ilc (void); +static void insrt_str (void); +static void new_ilc (int il_c_type); +static struct il_c *sep_ilc (char *s1,struct node *n,char *s2); + +#define SBufSz 256 + +static char sbuf[SBufSz]; /* buffer for constructing fragments of code */ +static int nxt_char; /* next position in sbuf */ +static struct token *line_ref; /* "recent" token for comparing line number */ +static struct il_c ilc_base; /* base for list of in-line C code */ +static struct il_c *ilc_cur; /* current end of list of in-line C code */ +static int insert_nl; /* flag: new-line should be inserted in code */ +static word cont_lbl = 0; /* destination label for C continue statement */ +static word brk_lbl = 0; /* destination label for C break statement */ + +/* + * inlin_c - Create a self-contained piece of in-line C code from a syntax + * sub-tree. + */ +struct il_c *inlin_c(n, may_mod) +struct node *n; +int may_mod; + { + init_ilc(); /* initialize code list and string buffer */ + ilc_walk(n, may_mod, 0); /* translate the syntax sub-tree */ + flush_str(); /* flush string buffer to code list */ + return ilc_base.next; + } + +/* + * simpl_dcl - produce a simple declaration both in the output file and as + * in-line C code. + */ +struct il_c *simpl_dcl(tqual, addr_of, sym) +char *tqual; +int addr_of; +struct sym_entry *sym; + { + init_ilc(); /* initialize code list and string buffer */ + prt_str(tqual, 0); + ilc_str(tqual); + if (addr_of) { + prt_str("*", 0); + ilc_str("*"); + } + prt_str(sym->image, 0); + ilc_str(sym->image); + prt_str(";", 0); + ForceNl(); + flush_str(); /* flush string buffer to code list */ + return ilc_base.next; + } + +/* + * parm_dcl - produce the declaration for a parameter to a body function. + * Print it in the output file and proceduce in-line C code for it. + */ +struct il_c *parm_dcl(addr_of, sym) +int addr_of; +struct sym_entry *sym; + { + init_ilc(); /* initialize code list and string buffer */ + + /* + * Produce type-qualifier list, but without non-type information. + */ + just_type(sym->u.declare_var.tqual, 0, 1); + prt_str(" ", 0); + ilc_str(" "); + + /* + * If the caller requested another level of indirection on the + * declaration add it. + */ + if (addr_of) + add_ptr(sym->u.declare_var.dcltor); + else { + c_walk(sym->u.declare_var.dcltor, 0, 0); + ilc_walk(sym->u.declare_var.dcltor, 0, 0); + } + prt_str(";", 0); + ForceNl(); + flush_str(); /* flush string buffer to code list */ + return ilc_base.next; + } + +/* + * add_ptr - add another level of indirection to a declarator. Print it in + * the output file and proceduce in-line C code. + */ +static void add_ptr(dcltor) +struct node *dcltor; + { + while (dcltor->nd_id == ConCatNd) { + c_walk(dcltor->u[0].child, IndentInc, 0); + ilc_walk(dcltor->u[0].child, 0, 0); + dcltor = dcltor->u[1].child; + } + switch (dcltor->nd_id) { + case PrimryNd: + /* + * We have reached the name, add a level of indirection. + */ + prt_str("(*", IndentInc); + ilc_str("(*"); + prt_str(dcltor->tok->image, IndentInc); + ilc_str(dcltor->tok->image); + prt_str(")", IndentInc); + ilc_str(")"); + break; + case PrefxNd: + /* + * (...) + */ + prt_str("(", IndentInc); + ilc_str("("); + add_ptr(dcltor->u[0].child); + prt_str(")", IndentInc); + ilc_str(")"); + break; + case BinryNd: + if (dcltor->tok->tok_id == ')') { + /* + * Function declaration. + */ + add_ptr(dcltor->u[0].child); + prt_str("(", IndentInc); + ilc_str("("); + c_walk(dcltor->u[1].child, IndentInc, 0); + ilc_walk(dcltor->u[1].child, 0, 0); + prt_str(")", IndentInc); + ilc_str(")"); + } + else { + /* + * Array. + */ + add_ptr(dcltor->u[0].child); + prt_str("[", IndentInc); + ilc_str("["); + c_walk(dcltor->u[1].child, IndentInc, 0); + ilc_walk(dcltor->u[1].child, 0, 0); + prt_str("]", IndentInc); + ilc_str("]"); + } + } + } + +/* + * bdy_prm - produce the code that must be be supplied as the argument + * to the call of a body function. + */ +struct il_c *bdy_prm(addr_of, just_desc, sym, may_mod) +int addr_of; +int just_desc; +struct sym_entry *sym; +int may_mod; + { + init_ilc(); /* initialize code list and string buffer */ + if (addr_of) + ilc_str("&("); /* call-by-reference parameter */ + ilc_var(sym, just_desc, may_mod); /* variable to pass as argument */ + if (addr_of) + ilc_str(")"); + flush_str(); /* flush string buffer to code list */ + return ilc_base.next; + } + +/* + * ilc_dcl - produce in-line code for a C declaration. + */ +struct il_c *ilc_dcl(tqual, dcltor, init) +struct node *tqual; +struct node *dcltor; +struct node *init; + { + init_ilc(); /* initialize code list and string buffer */ + ilc_walk(tqual, 0, 0); + ilc_str(" "); + ilc_walk(dcltor, 0, 0); + if (init != NULL) { + ilc_str(" = "); + ilc_walk(init, 0, 0); + } + ilc_str(";"); + flush_str(); /* flush string buffer to code list */ + return ilc_base.next; + } + + +/* + * init_ilc - initialize the code list by pointing to ilc_base. Initialize + * the string buffer. + */ +static void init_ilc() + { + nxt_char = 0; + line_ref = NULL; + insert_nl = 0; + ilc_base.il_c_type = 0; + ilc_base.next = NULL; + ilc_cur = &ilc_base; + } + + +/* + * - ilc_chnl - check for new-line. + */ +static void ilc_chnl(t) +struct token *t; + { + /* + * See if this is a reasonable place to put a newline. + */ + if (t->flag & LineChk) { + if (line_ref != NULL && + (t->fname != line_ref->fname || t->line != line_ref->line)) + insert_nl = 1; + line_ref = t; + } + } + +/* + * ilc_tok - convert a token to its string representation, quoting it + * if it is a string or character literal. + */ +static void ilc_tok(t) +struct token *t; + { + char *s; + + ilc_chnl(t); + s = t->image; + switch (t->tok_id) { + case StrLit: + ilc_str("\""); + ilc_str(s); + ilc_str("\""); + break; + case LStrLit: + ilc_str("L\""); + ilc_str(s); + ilc_str("\""); + break; + case CharConst: + ilc_str("'"); + ilc_str(s); + ilc_str("'"); + break; + case LCharConst: + ilc_str("L'"); + ilc_str(s); + ilc_str("'"); + break; + default: + ilc_str(s); + } + } + +/* + * ilc_str - append a string to the string buffer. + */ +static void ilc_str(s) +char *s; + { + /* + * see if a new-line is needed before the string + */ + if (insert_nl && (nxt_char == 0 || sbuf[nxt_char - 1] != '\n')) { + insert_nl = 0; + ilc_str("\n"); + } + + /* + * Put the string in the buffer. If the buffer is full, flush it + * to an element in the in-line code list. + */ + while (*s != '\0') { + if (nxt_char >= SBufSz - 1) + insrt_str(); + sbuf[nxt_char++] = *s++; + } + } + +/* + * insrt_str - insert the string in the buffer into the list of in-line + * code. + */ +static void insrt_str() + { + alloc_ilc(ILC_Str); + sbuf[nxt_char] = '\0'; + ilc_cur->s = salloc(sbuf); + nxt_char = 0; + } + +/* + * flush_str - if the string buffer is not empty, flush it to the list + * of in-line code. + */ +static void flush_str() + { + if (insert_nl) + ilc_str(""); + if (nxt_char != 0) + insrt_str(); + } + +/* + * new_ilc - create a new element for the list of in-line C code. This + * is called for non-string elements. If necessary it flushes the + * string buffer to another element first. + */ +static void new_ilc(il_c_type) +int il_c_type; + { + flush_str(); + alloc_ilc(il_c_type); + } + +/* + * alloc_ilc - allocate a new element for the list of in-line C code + * and add it to the list. + */ +static void alloc_ilc(il_c_type) +int il_c_type; + { + int i; + ilc_cur->next = NewStruct(il_c); + ilc_cur = ilc_cur->next; + ilc_cur->next = NULL; + ilc_cur->il_c_type = il_c_type; + for (i = 0; i < 3; ++i) + ilc_cur->code[i] = NULL; + ilc_cur->n = 0; + ilc_cur->s = NULL; + } + +/* + * sep_ilc - translate the syntax tree, n, (possibly surrounding it by + * strings) into a sub-list of in-line C code, remove the sub-list from + * the main list, and return it. + */ +static struct il_c *sep_ilc(s1, n, s2) +char *s1; +struct node *n; +char *s2; + { + struct il_c *ilc; + + ilc = ilc_cur; /* remember the starting point in the main list */ + if (s1 != NULL) + ilc_str(s1); + ilc_walk(n, 0, 0); + if (s2 != NULL) + ilc_str(s2); + flush_str(); + + /* + * Reset the main list to its condition upon entry, and return the sublist + * created from s1, n, and s2. + */ + ilc_cur = ilc; + ilc = ilc_cur->next; + ilc_cur->next = NULL; + return ilc; + } + +/* + * ilc_var - create in-line C code for a variable in the symbol table. + */ +static void ilc_var(sym, just_desc, may_mod) +struct sym_entry *sym; +int just_desc; +int may_mod; + { + if (sym->il_indx >= 0) { + /* + * This symbol will be in symbol table iconc builds from the + * data base entry. iconc needs to know if this is a modifying + * reference so it can perform optimizations. This is indicated by + * may_mod. Some variables are implemented as the vword of a + * descriptor. Sometime the entire descriptor must be accessed. + * This is indicated by just_desc. + */ + if (may_mod) { + new_ilc(ILC_Mod); + if (sym->id_type & DrfPrm) + sym->u.param_info.parm_mod |= 1; + } + else + new_ilc(ILC_Ref); + ilc_cur->n = sym->il_indx; + if (just_desc) + ilc_cur->s = "d"; + } + else switch (sym->id_type) { + case TndDesc: + /* + * variable declared: tended struct descrip ... + */ + new_ilc(ILC_Tend); + ilc_cur->n = sym->t_indx; /* index into tended variables */ + break; + case TndStr: + /* + * variable declared: tended char *... + */ + new_ilc(ILC_Tend); + ilc_cur->n = sym->t_indx; /* index into tended variables */ + ilc_str(".vword.sptr"); /* get string pointer from vword union */ + break; + case TndBlk: + /* + * If blk_name field is null, this variable was declared: + * tended union block *... + * otherwise it was declared: + * tended struct *... + */ + if (sym->u.tnd_var.blk_name != NULL) { + /* + * Cast the "union block *" from the vword to the correct + * struct pointer. This cast can be used as an r-value or + * an l-value. + */ + ilc_str("(*(struct "); + ilc_str(sym->u.tnd_var.blk_name); + ilc_str("**)&"); + } + new_ilc(ILC_Tend); + ilc_cur->n = sym->t_indx; /* index into tended variables */ + ilc_str(".vword.bptr"); /* get block pointer from vword union */ + if (sym->u.tnd_var.blk_name != NULL) + ilc_str(")"); + break; + case RsltLoc: + /* + * This is the special variable for the result of the operation. + * iconc needs to know if this is a modifying reference so it + * can perform optimizations. + */ + if (may_mod) + new_ilc(ILC_Mod); + else + new_ilc(ILC_Ref); + ilc_cur->n = RsltIndx; + break; + default: + /* + * This is a variable with an ordinary declaration. Access it by + * its identifier. + */ + ilc_str(sym->image); + } + } + +/* + * ilc_walk - walk the syntax tree for C code producing a list of "in-line" + * code. This function needs to know if the code is in a modifying context, + * such as the left-hand-side of an assignment. + */ +static void ilc_walk(n, may_mod, const_cast) +struct node *n; +int may_mod; +int const_cast; + { + struct token *t; + struct node *n1; + struct node *n2; + struct sym_entry *sym; + word cont_sav; + word brk_sav; + word l1, l2; + int typcd; + + if (n == NULL) + return; + + t = n->tok; + + switch (n->nd_id) { + case PrimryNd: + /* + * Primary expressions consisting of a single token. + */ + switch (t->tok_id) { + case Fail: + /* + * fail statement. Note that this operaion can fail, output + * the corresponding "in-line" code, and make sure we have + * seen an abstract clause of some kind. + */ + cur_impl->ret_flag |= DoesFail; + insert_nl = 1; + new_ilc(ILC_Fail); + insert_nl = 1; + line_ref = NULL; + chkabsret(t, SomeType); + break; + case Errorfail: + /* + * errorfail statement. Note that this operaion can do error + * conversion and output the corresponding "in-line" code. + */ + cur_impl->ret_flag |= DoesEFail; + insert_nl = 1; + new_ilc(ILC_EFail); + insert_nl = 1; + line_ref = NULL; + break; + case Break: + /* + * iconc can only handle gotos for transfer of control in + * in-line code. A break label has been established for + * the current loop; transform the "break" into a goto. + */ + ilc_goto(brk_lbl); + break; + case Continue: + /* + * iconc can only handle gotos for transfer of control in + * in-line code. A continue label has been established for + * the current loop; transform the "continue" into a goto. + */ + ilc_goto(cont_lbl); + break; + default: + /* + * No special processing is needed for this primary + * expression, just output the image of the token. + */ + ilc_tok(t); + } + break; + case PrefxNd: + /* + * Expressions with one operand that are introduced by a token. + * Note, "default :" does not appear here because switch + * statements are not allowed in in-line code. + */ + switch (t->tok_id) { + case Sizeof: + /* + * sizeof(...) + */ + ilc_tok(t); + ilc_str("("); + ilc_walk(n->u[0].child, 0, 0); + ilc_str(")"); + break; + case '{': + /* + * initializer: { ... } + */ + ilc_tok(t); + ilc_walk(n->u[0].child, 0, 0); + ilc_str("}"); + break; + case Goto: + /* + * goto